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