lisp/cedet/semantic/util.el

   1 ;;; semantic/util.el --- Utilities for use with semantic tag tables
   2
   3 ;;; Copyright (C) 1999-2005, 2007-2014 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric M. Ludlam <zappo@gnu.org>
   6 ;; Keywords: syntax
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Semantic utility API for use with semantic tag tables.
  26 ;;
  27
  28 (require 'semantic)
  29
  30 (eval-when-compile
  31   (require 'semantic/db-find)
  32   ;; For semantic-find-tags-by-class, semantic--find-tags-by-function,
  33   ;; and semantic-brute-find-tag-standard:
  34   (require 'semantic/find))
  35
  36 (declare-function data-debug-insert-stuff-list "data-debug")
  37 (declare-function data-debug-insert-thing "data-debug")
  38 (declare-function semantic-ctxt-current-symbol-and-bounds "semantic/ctxt")
  39
  40 ;;; Code:
  41
  42 (defvar semantic-type-relation-separator-character '(".")
  43   "Character strings used to separate a parent/child relationship.
  44 This list of strings are used for displaying or finding separators
  45 in variable field dereferencing.  The first character will be used for
  46 display.  In C, a type field is separated like this: \"type.field\"
  47 thus, the character is a \".\".  In C, and additional value of \"->\"
  48 would be in the list, so that \"type->field\" could be found.")
  49 (make-variable-buffer-local 'semantic-type-relation-separator-character)
  50
  51 (defvar semantic-equivalent-major-modes nil
  52   "List of major modes which are considered equivalent.
  53 Equivalent modes share a parser, and a set of override methods.
  54 A value of nil means that the current major mode is the only one.")
  55 (make-variable-buffer-local 'semantic-equivalent-major-modes)
  56
  57 ;; These semanticdb calls will throw warnings in the byte compiler.
  58 ;; Doing the right thing to make them available at compile time
  59 ;; really messes up the compilation sequence.
  60 (defun semantic-file-tag-table (file)
  61   "Return a tag table for FILE.
  62 If it is loaded, return the stream after making sure it's ok.
  63 If FILE is not loaded, check to see if `semanticdb' feature exists,
  64    and use it to get tags from files not in memory.
  65 If FILE is not loaded, and semanticdb is not available, find the file
  66    and parse it."
  67   (save-match-data
  68     (if (find-buffer-visiting file)
  69         (with-current-buffer (find-buffer-visiting file)
  70           (semantic-fetch-tags))
  71       ;; File not loaded
  72       (if (and (require 'semantic/db-mode)
  73                (semanticdb-minor-mode-p))
  74           ;; semanticdb is around, use it.
  75           (semanticdb-file-stream file)
  76         ;; Get the stream ourselves.
  77         (with-current-buffer (find-file-noselect file)
  78           (semantic-fetch-tags))))))
  79
  80 (semantic-alias-obsolete 'semantic-file-token-stream
  81                          'semantic-file-tag-table "23.2")
  82
  83 (defun semantic-something-to-tag-table (something)
  84   "Convert SOMETHING into a semantic tag table.
  85 Something can be a tag with a valid BUFFER property, a tag table, a
  86 buffer, or a filename.  If SOMETHING is nil return nil."
  87   (cond
  88    ;; A list of tags
  89    ((and (listp something)
  90          (semantic-tag-p (car something)))
  91     something)
  92    ;; A buffer
  93    ((bufferp something)
  94     (with-current-buffer something
  95       (semantic-fetch-tags)))
  96    ;; A Tag: Get that tag's buffer
  97    ((and (semantic-tag-with-position-p something)
  98          (semantic-tag-in-buffer-p something))
  99     (with-current-buffer (semantic-tag-buffer something)
 100       (semantic-fetch-tags)))
 101    ;; Tag with a file name in it
 102    ((and (semantic-tag-p something)
 103          (semantic-tag-file-name something)
 104          (file-exists-p (semantic-tag-file-name something)))
 105     (semantic-file-tag-table
 106      (semantic-tag-file-name something)))
 107    ;; A file name
 108    ((and (stringp something)
 109          (file-exists-p something))
 110     (semantic-file-tag-table something))
 111    ;; A Semanticdb table
 112    ((and (featurep 'semantic/db)
 113          (semanticdb-minor-mode-p)
 114          (semanticdb-abstract-table-child-p something))
 115     (semanticdb-refresh-table something)
 116     (semanticdb-get-tags something))
 117    ;; Semanticdb find-results
 118    ((and (featurep 'semantic/db)
 119          (semanticdb-minor-mode-p)
 120          (require 'semantic/db-find)
 121          (semanticdb-find-results-p something))
 122     (semanticdb-strip-find-results something))
 123    ;; NOTE: This commented out since if a search result returns
 124    ;;       empty, that empty would turn into everything on the next search.
 125    ;; Use the current buffer for nil
 126 ;;   ((null something)
 127 ;;    (semantic-fetch-tags))
 128    ;; don't know what it is
 129    (t nil)))
 130
 131 (semantic-alias-obsolete 'semantic-something-to-stream
 132                          'semantic-something-to-tag-table "23.2")
 133
 134 ;;; Completion APIs
 135 ;;
 136 ;; These functions provide minibuffer reading/completion for lists of
 137 ;; nonterminals.
 138 (defvar semantic-read-symbol-history nil
 139   "History for a symbol read.")
 140
 141 (defun semantic-read-symbol (prompt &optional default stream filter)
 142   "Read a symbol name from the user for the current buffer.
 143 PROMPT is the prompt to use.
 144 Optional arguments:
 145 DEFAULT is the default choice.  If no default is given, one is read
 146 from under point.
 147 STREAM is the list of tokens to complete from.
 148 FILTER is provides a filter on the types of things to complete.
 149 FILTER must be a function to call on each element."
 150   (if (not default) (setq default (thing-at-point 'symbol)))
 151   (if (not stream) (setq stream (semantic-fetch-tags)))
 152   (setq stream
 153         (if filter
 154             (semantic--find-tags-by-function filter stream)
 155           (semantic-brute-find-tag-standard stream)))
 156   (if (and default (string-match ":" prompt))
 157       (setq prompt
 158             (concat (substring prompt 0 (match-end 0))
 159                     " (default: " default ") ")))
 160   (completing-read prompt stream nil t ""
 161                    'semantic-read-symbol-history
 162                    default))
 163
 164 (defun semantic-read-variable (prompt &optional default stream)
 165   "Read a variable name from the user for the current buffer.
 166 PROMPT is the prompt to use.
 167 Optional arguments:
 168 DEFAULT is the default choice.  If no default is given, one is read
 169 from under point.
 170 STREAM is the list of tokens to complete from."
 171   (semantic-read-symbol
 172    prompt default
 173    (or (semantic-find-tags-by-class
 174         'variable (or stream (current-buffer)))
 175        (error "No local variables"))))
 176
 177 (defun semantic-read-function (prompt &optional default stream)
 178   "Read a function name from the user for the current buffer.
 179 PROMPT is the prompt to use.
 180 Optional arguments:
 181 DEFAULT is the default choice.  If no default is given, one is read
 182 from under point.
 183 STREAM is the list of tags to complete from."
 184   (semantic-read-symbol
 185    prompt default
 186    (or (semantic-find-tags-by-class
 187         'function (or stream (current-buffer)))
 188        (error "No local functions"))))
 189
 190 (defun semantic-read-type (prompt &optional default stream)
 191   "Read a type name from the user for the current buffer.
 192 PROMPT is the prompt to use.
 193 Optional arguments:
 194 DEFAULT is the default choice.  If no default is given, one is read
 195 from under point.
 196 STREAM is the list of tags to complete from."
 197   (semantic-read-symbol
 198    prompt default
 199    (or (semantic-find-tags-by-class
 200         'type (or stream (current-buffer)))
 201        (error "No local types"))))
 202
 203 \f
 204 ;;; Interactive Functions for
 205 ;;
 206 (defun semantic-describe-tag (&optional tag)
 207   "Describe TAG in the minibuffer.
 208 If TAG is nil, describe the tag under the cursor."
 209   (interactive)
 210   (if (not tag) (setq tag (semantic-current-tag)))
 211   (semantic-fetch-tags)
 212   (if tag (message (semantic-format-tag-summarize tag))))
 213
 214 \f
 215 ;;; Putting keys on tags.
 216 ;;
 217 (defun semantic-add-label (label value &optional tag)
 218   "Add a LABEL with VALUE on TAG.
 219 If TAG is not specified, use the tag at point."
 220   (interactive "sLabel: \nXValue (eval): ")
 221   (if (not tag)
 222       (progn
 223         (semantic-fetch-tags)
 224         (setq tag (semantic-current-tag))))
 225   (semantic--tag-put-property tag (intern label) value)
 226   (message "Added label %s with value %S" label value))
 227
 228 (defun semantic-show-label (label &optional tag)
 229   "Show the value of LABEL on TAG.
 230 If TAG is not specified, use the tag at point."
 231   (interactive "sLabel: ")
 232   (if (not tag)
 233       (progn
 234         (semantic-fetch-tags)
 235         (setq tag (semantic-current-tag))))
 236   (message "%s: %S" label (semantic--tag-get-property tag (intern label))))
 237
 238 \f
 239 ;;; Hacks
 240 ;;
 241 ;; Some hacks to help me test these functions
 242 (defun semantic-describe-buffer-var-helper (varsym buffer)
 243   "Display to standard out the value of VARSYM in BUFFER."
 244   (require 'data-debug)
 245   (let ((value (with-current-buffer buffer
 246                  (symbol-value varsym))))
 247     (cond
 248      ((and (consp value)
 249            (< (length value) 10))
 250       ;; Draw the list of things in the list.
 251       (princ (format "  %s:  #<list of %d items>\n"
 252                      varsym (length value)))
 253       (data-debug-insert-stuff-list
 254        value "    " )
 255       )
 256      (t
 257       ;; Else do a one-liner.
 258       (data-debug-insert-thing
 259        value " " (concat " " (symbol-name varsym) ": "))
 260       ))))
 261
 262 (defun semantic-describe-buffer ()
 263   "Describe the semantic environment for the current buffer."
 264   (interactive)
 265   (let ((buff (current-buffer))
 266         )
 267
 268     (with-output-to-temp-buffer (help-buffer)
 269       (help-setup-xref (list #'semantic-describe-buffer)
 270                        (called-interactively-p 'interactive))
 271       (with-current-buffer standard-output
 272         (princ "Semantic Configuration in ")
 273         (princ (buffer-name buff))
 274         (princ "\n\n")
 275
 276         (princ "Buffer specific configuration items:\n")
 277         (let ((vars '(major-mode
 278                       semantic-case-fold
 279                       semantic-tag-expand-function
 280                       semantic-parser-name
 281                       semantic-parse-tree-state
 282                       semantic-lex-analyzer
 283                       semantic-lex-reset-functions
 284                       semantic-lex-syntax-modifications
 285                       )))
 286           (dolist (V vars)
 287             (semantic-describe-buffer-var-helper V buff)))
 288
 289         (princ "\nGeneral configuration items:\n")
 290         (let ((vars '(semantic-inhibit-functions
 291                       semantic-init-hook
 292                       semantic-init-db-hook
 293                       semantic-unmatched-syntax-hook
 294                       semantic--before-fetch-tags-hook
 295                       semantic-after-toplevel-bovinate-hook
 296                       semantic-after-toplevel-cache-change-hook
 297                       semantic-before-toplevel-cache-flush-hook
 298                       semantic-dump-parse
 299                       semantic-type-relation-separator-character
 300                       semantic-command-separation-character
 301                       semantic-new-buffer-fcn-was-run
 302                       )))
 303           (dolist (V vars)
 304             (semantic-describe-buffer-var-helper V buff)))
 305
 306         (princ "\n\n")
 307         (mode-local-describe-bindings-2 buff)
 308         )))
 309   )
 310
 311 (defun semantic-assert-valid-token (tok)
 312   "Assert that TOK is a valid token."
 313   (if (semantic-tag-p tok)
 314       (if (semantic-tag-with-position-p tok)
 315           (let ((o  (semantic-tag-overlay tok)))
 316             (if (and (semantic-overlay-p o)
 317                      (not (semantic-overlay-live-p o)))
 318                 (let ((debug-on-error t))
 319                   (error "Tag %s is invalid!" (semantic-tag-name tok)))
 320               ;; else, tag is OK.
 321               ))
 322         ;; Positionless tags are also ok.
 323         )
 324     (let ((debug-on-error t))
 325       (error "Not a semantic tag: %S" tok))))
 326
 327 (defun semantic-sanity-check (&optional cache over notfirst)
 328   "Perform a sanity check on the current buffer.
 329 The buffer's set of overlays, and those overlays found via the cache
 330 are verified against each other.
 331 CACHE, and OVER are the semantic cache, and the overlay list.
 332 NOTFIRST indicates that this was not the first call in the recursive use."
 333   (interactive)
 334   (if (and (not cache) (not over) (not notfirst))
 335       (setq cache semantic--buffer-cache
 336             over (semantic-overlays-in (point-min) (point-max))))
 337   (while cache
 338     (let ((chil (semantic-tag-components-with-overlays (car cache))))
 339       (if (not (memq (semantic-tag-overlay (car cache)) over))
 340           (message "Tag %s not in buffer overlay list."
 341                    (semantic-format-tag-concise-prototype (car cache))))
 342       (setq over (delq (semantic-tag-overlay (car cache)) over))
 343       (setq over (semantic-sanity-check chil over t))
 344       (setq cache (cdr cache))))
 345   (if (not notfirst)
 346       ;; Strip out all overlays which aren't semantic overlays
 347       (let ((o nil))
 348         (while over
 349           (when (and (semantic-overlay-get (car over) 'semantic)
 350                      (not (eq (semantic-overlay-get (car over) 'semantic)
 351                               'unmatched)))
 352             (setq o (cons (car over) o)))
 353           (setq over (cdr over)))
 354         (when (called-interactively-p 'any)
 355           (message "Remaining overlays: %S" o))))
 356   over)
 357
 358 ;;; Interactive commands (from Senator).
 359
 360 ;; The Senator library from upstream CEDET is not included in the
 361 ;; built-in version of Emacs.  The plan is to fold it into the
 362 ;; different parts of CEDET and Emacs, so that it works
 363 ;; "transparently".  Here are some interactive commands based on
 364 ;; Senator.
 365
 366 ;; Symbol completion
 367
 368 (defun semantic-find-tag-for-completion (prefix)
 369   "Find all tags with name starting with PREFIX.
 370 This uses `semanticdb' when available."
 371   (let (result ctxt)
 372     ;; Try the Semantic analyzer
 373     (condition-case nil
 374         (and (featurep 'semantic/analyze)
 375              (setq ctxt (semantic-analyze-current-context))
 376              (setq result (semantic-analyze-possible-completions ctxt)))
 377       (error nil))
 378     (or result
 379         ;; If the analyzer fails, then go into boring completion.
 380         (if (and (featurep 'semantic/db)
 381                  (semanticdb-minor-mode-p)
 382                  (require 'semantic/db-find))
 383             (semanticdb-fast-strip-find-results
 384              (semanticdb-deep-find-tags-for-completion prefix))
 385           (semantic-deep-find-tags-for-completion prefix (current-buffer))))))
 386
 387 (defun semantic-complete-symbol (&optional predicate)
 388   "Complete the symbol under point, using Semantic facilities.
 389 When called from a program, optional arg PREDICATE is a predicate
 390 determining which symbols are considered."
 391   (interactive)
 392   (require 'semantic/ctxt)
 393   (let* ((start (car (nth 2 (semantic-ctxt-current-symbol-and-bounds
 394                              (point)))))
 395          (pattern (regexp-quote (buffer-substring start (point))))
 396          collection completion)
 397     (when start
 398       (if (and semantic--completion-cache
 399                (eq (nth 0 semantic--completion-cache) (current-buffer))
 400                (=  (nth 1 semantic--completion-cache) start)
 401                (save-excursion
 402                  (goto-char start)
 403                  (looking-at (nth 3 semantic--completion-cache))))
 404           ;; Use cached value.
 405           (setq collection (nthcdr 4 semantic--completion-cache))
 406         ;; Perform new query.
 407         (setq collection (semantic-find-tag-for-completion pattern))
 408         (setq semantic--completion-cache
 409               (append (list (current-buffer) start 0 pattern)
 410                       collection))))
 411     (if (null collection)
 412         (let ((str (if pattern (format " for \"%s\"" pattern) "")))
 413           (if (window-minibuffer-p (selected-window))
 414               (minibuffer-message (format " [No completions%s]" str))
 415             (message "Can't find completion%s" str)))
 416       (setq completion (try-completion pattern collection predicate))
 417       (if (string= pattern completion)
 418           (let ((list (all-completions pattern collection predicate)))
 419             (setq list (sort list 'string<))
 420             (if (> (length list) 1)
 421                 (with-output-to-temp-buffer "*Completions*"
 422                   (display-completion-list list pattern))
 423               ;; Bury any out-of-date completions buffer.
 424               (let ((win (get-buffer-window "*Completions*" 0)))
 425                 (if win (with-selected-window win (bury-buffer))))))
 426         ;; Exact match
 427         (delete-region start (point))
 428         (insert completion)
 429         ;; Bury any out-of-date completions buffer.
 430         (let ((win (get-buffer-window "*Completions*" 0)))
 431           (if win (with-selected-window win (bury-buffer))))))))
 432
 433 (provide 'semantic/util)
 434
 435 ;;; Minor modes
 436 ;;
 437 (require 'semantic/util-modes)
 438
 439 ;;; semantic/util.el ends here