1 ;; gpr-query.el --- Minor mode for navigating sources using gpr_query -*- lexical-binding:t -*-
3 ;; gpr-query supports Ada and any gcc language that supports the
4 ;; AdaCore -fdump-xref switch (which includes C, C++).
6 ;; Copyright (C) 2013 - 2015 Free Software Foundation, Inc.
8 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
9 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
12 ;; This file is part of GNU Emacs.
14 ;; GNU Emacs is free software: you can redistribute it and/or modify
15 ;; it under the terms of the GNU General Public License as published by
16 ;; the Free Software Foundation, either version 3 of the License, or
17 ;; (at your option) any later version.
19 ;; GNU Emacs is distributed in the hope that it will be useful,
20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;; GNU General Public License for more details.
24 ;; You should have received a copy of the GNU General Public License
25 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 (require 'ada-mode-compat-24.2)
33 (require 'ada-mode) ;; for ada-prj-*, some other things
40 ;; gpr_query reads the project files and the database at startup,
41 ;; which is noticeably slow for a reasonably sized project. But
42 ;; running queries after startup is fast. So we leave gpr_query
43 ;; running, and send it new queries via stdin, getting responses via
46 ;; We maintain a cache of active sessions, one per gnat project.
48 (cl-defstruct (gpr-query--session)
49 (process nil) ;; running gpr_query
50 (buffer nil)) ;; receives output of gpr_query
52 (defconst gpr-query-buffer-name-prefix " *gpr_query-")
54 (defun gpr-query--start-process (session)
55 "Start the session process running gpr_query."
56 (unless (buffer-live-p (gpr-query--session-buffer session))
57 ;; user may have killed buffer
58 (setf (gpr-query--session-buffer session) (gnat-run-buffer gpr-query-buffer-name-prefix)))
60 (with-current-buffer (gpr-query--session-buffer session)
61 (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
63 (project-file (file-name-nondirectory (ada-prj-get 'gpr_file))))
64 (erase-buffer); delete any previous messages, prompt
65 (setf (gpr-query--session-process session)
66 ;; gnatcoll-1.6 can't handle aggregate projects; M910-032
67 ;; gpr_query can handle some aggregate projects, but not all
68 (start-process (concat "gpr_query " (buffer-name))
69 (gpr-query--session-buffer session)
71 (concat "--project=" project-file)))
72 (set-process-query-on-exit-flag (gpr-query--session-process session) nil)
73 (gpr-query-session-wait session)
75 ;; Check for warnings about invalid directories etc. But some
76 ;; warnings are tolerable, so only abort if process actually
78 (if (process-live-p (gpr-query--session-process session))
80 (goto-char (point-min))
81 (when (search-forward "warning:" nil t)
83 (message "gpr_query warnings")))
85 (error "gpr-query process failed to start"))
88 (defun gpr-query--make-session ()
89 "Create and return a session for the current project file."
91 (make-gpr-query--session
92 :buffer (gnat-run-buffer gpr-query-buffer-name-prefix))))
93 (gpr-query--start-process session)
96 (defvar gpr-query--sessions '()
97 "Assoc list of sessions, indexed by absolute GNAT project file name.")
99 (defun gpr-query-cached-session ()
100 "Return a session for the current project file, creating it if necessary."
101 (let* ((session (cdr (assoc ada-prj-current-file gpr-query--sessions))))
104 (unless (process-live-p (gpr-query--session-process session))
105 (gpr-query--start-process session))
109 (setq session (gpr-query--make-session))
110 (setq gpr-query--sessions
111 (cl-acons ada-prj-current-file session gpr-query--sessions))))
114 (defconst gpr-query-prompt "^>>> $"
115 ;; gpr_query output ends with this
116 "Regexp matching gpr_query prompt; indicates previous command is complete.")
118 (defun gpr-query-session-wait (session)
119 "Wait for the current command to complete."
120 (unless (process-live-p (gpr-query--session-process session))
121 (gpr-query-show-buffer session)
122 (error "gpr-query process died"))
124 (with-current-buffer (gpr-query--session-buffer session)
125 (let ((process (gpr-query--session-process session))
126 (search-start (point-min))
128 (while (and (process-live-p process)
130 ;; process output is inserted before point, so move back over it to search it
131 (goto-char search-start)
132 (not (re-search-forward gpr-query-prompt (point-max) 1))))
133 (setq search-start (point));; don't search same text again
134 (message (concat "running gpr_query ..." (make-string wait-count ?.)))
135 ;; IMPROVEME: use --display-progress
136 (accept-process-output process 1.0)
137 (setq wait-count (1+ wait-count)))
138 (if (process-live-p process)
139 (message (concat "running gpr_query ... done"))
140 (gpr-query-show-buffer session)
141 (error "gpr_query process died"))
144 (defun gpr-require-prj ()
145 "Throw error if no project file defined."
146 (unless (or (ada-prj-get 'gpr_file)
147 (ada-prj-get 'gpr_query_file))
148 (error "no gpr project file defined.")))
150 (defun gpr-query-session-send (cmd wait)
151 "Send CMD to gpr_query session for current project.
152 If WAIT is non-nil, wait for command to complete.
153 Return buffer that holds output."
155 (let ((session (gpr-query-cached-session)))
156 ;; always wait for previous command to complete; also checks for
158 (gpr-query-session-wait session)
159 (with-current-buffer (gpr-query--session-buffer session)
161 (process-send-string (gpr-query--session-process session)
164 (gpr-query-session-wait session))
168 (defun gpr-query-kill-session (session)
169 (let ((process (gpr-query--session-process session)))
170 (when (process-live-p process)
171 (process-send-string (gpr-query--session-process session) "exit\n")
172 (while (process-live-p process)
173 (accept-process-output process 1.0)))
176 (defun gpr-query-kill-all-sessions ()
179 (mapc (lambda (assoc)
180 (let ((session (cdr assoc)))
181 (when (process-live-p (gpr-query--session-process session))
182 (setq count (1+ count))
183 (process-send-string (gpr-query--session-process session) "exit\n")
186 (message "Killed %d sessions" count)
189 (defun gpr-query-show-buffer (&optional session)
190 "For `ada-show-xref-tool-buffer'; show gpr-query buffer for current project."
192 (pop-to-buffer (gpr-query--session-buffer (or session (gpr-query-cached-session)))))
196 (defun gpr-query-get-src-dirs (src-dirs)
197 "Append list of source dirs in current gpr project to SRC-DIRS.
198 Uses `gpr_query'. Returns new list."
200 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
201 (gpr-query-session-send "source_dirs" t)
202 (goto-char (point-min))
203 (while (not (looking-at gpr-query-prompt))
204 (cl-pushnew (directory-file-name
205 (buffer-substring-no-properties (point) (point-at-eol)))
206 src-dirs :test #'equal)
211 (defun gpr-query-get-prj-dirs (prj-dirs)
212 "Append list of project dirs in current gpr project to PRJ-DIRS.
213 Uses `gpr_query'. Returns new list."
215 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
216 (gpr-query-session-send "project_path" t)
217 (goto-char (point-min))
218 (while (not (looking-at gpr-query-prompt))
220 (let ((dir (buffer-substring-no-properties (point) (point-at-eol))))
221 (if (string= dir ".")
222 (directory-file-name default-directory)
230 (defconst gpr-query-ident-file-regexp
231 ;; C:\Projects\GDS\work_dscovr_release\common\1553\gds-mil_std_1553-utf.ads:252:25
232 ;; /Projects/GDS/work_dscovr_release/common/1553/gds-mil_std_1553-utf.ads:252:25
233 "\\(\\(?:.:\\\\\\|/\\)[^:]*\\):\\([0123456789]+\\):\\([0123456789]+\\)"
235 "Regexp matching <file>:<line>:<column>")
237 (defconst gpr-query-ident-file-regexp-alist
238 (list (concat "^" gpr-query-ident-file-regexp) 1 2 3)
239 "For compilation-error-regexp-alist, matching gpr_query output")
241 (defconst gpr-query-ident-file-type-regexp
242 (concat gpr-query-ident-file-regexp " (\\(.*\\))")
243 "Regexp matching <file>:<line>:<column> (<type>)")
245 (defun gpr-query-compilation (identifier file line col cmd comp-err)
246 "Run gpr_query IDENTIFIER:FILE:LINE:COL CMD,
247 set compilation-mode with compilation-error-regexp-alist set to COMP-ERR."
248 ;; Useful when gpr_query will return a list of references; we use
249 ;; `compilation-start' to run gpr_query, so the user can navigate
250 ;; to each result in turn via `next-error'.
251 (let ((cmd-1 (format "%s %s:%s:%d:%d" cmd identifier file line col))
253 target-file target-line target-col)
254 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
256 (setq buffer-read-only nil)
257 (set (make-local-variable 'compilation-error-regexp-alist) (list comp-err))
258 (gpr-query-session-send cmd-1 t)
260 ;; point is at EOB. gpr_query returns one line per result plus prompt, warnings
261 (setq result-count (- (line-number-at-pos) 1))
264 ;; pre Emacs 25, font-lock-ensure applies compilation-message
267 ;; post Emacs 25, compilation-next-error applies
268 ;; compilation-message text properties on the fly via
269 ;; compilation--ensure-parse. But that doesn't apply face text
272 ;; IMPROVEME: next-error works, but the font colors are not
273 ;; right (bad regexp?)
275 (goto-char (point-min))
277 ((looking-at "^warning: ")
278 (setq result-count (1- result-count))
280 ((looking-at "^Error: entity not found")
281 (error (buffer-substring-no-properties (line-beginning-position) (line-end-position))))
284 (cl-case result-count
286 (error "gpr_query returned no results"))
288 ;; just go there, don't display session-buffer. We have to
289 ;; fetch the compilation-message while in the
290 ;; session-buffer. and call ada-goot-source outside the
291 ;; with-current-buffer above.
292 (compilation--ensure-parse (point-max))
293 (let* ((msg (compilation-next-error 0))
294 ;; IMPROVEME: '--' indicates internal-only. But we can't
295 ;; use compile-goto-error, because that displays the
297 (loc (compilation--message->loc msg)))
298 (setq target-file (caar (compilation--loc->file-struct loc))
299 target-line (caar (cddr (compilation--loc->file-struct loc)))
300 target-col (1- (compilation--loc->col loc))
305 ;; for next-error, below
306 (setq next-error-last-buffer (current-buffer)))
308 ));; case, with-currrent-buffer
310 (if (= result-count 1)
311 (ada-goto-source target-file target-line target-col nil)
313 ;; more than one result; display session buffer, goto first ref
315 ;; compilation-next-error-function assumes there is not an error
316 ;; at point-min; work around that by moving forward 0 errors for
317 ;; the first one. Unless the first line contains "warning: ".
318 (set-buffer next-error-last-buffer)
319 (goto-char (point-min))
320 (if (looking-at "^warning: ")
326 (defun gpr-query-dist (found-line line found-col col)
327 "Return distance between FOUND-LINE FOUND-COL and LINE COL."
328 (+ (abs (- found-col col))
329 (* (abs (- found-line line)) 250)))
331 ;;;;; user interface functions
333 (defun gpr-query-show-references ()
334 "Show all references of identifier at point."
337 (thing-at-point 'symbol)
338 (file-name-nondirectory (buffer-file-name))
340 (1+ (current-column)))
343 (defun gpr-query-overridden (other-window)
344 "Move to the overridden declaration of the identifier around point.
345 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
346 buffer in another window."
350 (gpr-query-overridden-1
351 (thing-at-point 'symbol)
355 (goto-char (car (bounds-of-thing-at-point 'symbol)))
356 (1+ (current-column)))
359 (ada-goto-source (nth 0 target)
365 (defun gpr-query-goto-declaration (other-window)
366 "Move to the declaration or body of the identifier around point.
367 If at the declaration, go to the body, and vice versa. If at a
368 reference, goto the declaration.
370 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
371 buffer in another window."
376 (thing-at-point 'symbol)
380 (goto-char (car (bounds-of-thing-at-point 'symbol)))
381 (1+ (current-column)))
384 (ada-goto-source (nth 0 target)
390 (defvar gpr-query-map
391 (let ((map (make-sparse-keymap)))
392 ;; C-c C-i prefix for gpr-query minor mode
394 (define-key map "\C-c\C-i\C-d" 'gpr-query-goto-declaration)
395 (define-key map "\C-c\C-i\C-p" 'ada-build-prompt-select-prj-file)
396 (define-key map "\C-c\C-i\C-q" 'gpr-query-refresh)
397 (define-key map "\C-c\C-i\C-r" 'gpr-query-show-references)
398 ;; IMPROVEME: (define-key map "\C-c\M-d" 'gpr-query-parents)
399 ;; IMPROVEME: overriding
401 ) "Local keymap used for gpr query minor mode.")
403 (defvar gpr-query-menu (make-sparse-keymap "gpr-query"))
404 (easy-menu-define gpr-query-menu gpr-query-map "Menu keymap for gpr-query minor mode"
406 ["Find and select project ..." ada-build-prompt-select-prj-file t]
407 ["Select project ..." ada-prj-select t]
408 ["Show current project" ada-prj-show t]
409 ["Show gpr-query buffer" gpr-query-show-buffer t]
410 ["Next compilation error" next-error t]
411 ["Show secondary error" ada-show-secondary-error t]
412 ["Goto declaration/body" gpr-query-goto-declaration t]
413 ["Show parent declarations" ada-show-declaration-parents t]
414 ["Show references" gpr-query-show-references t]
415 ;; ["Show overriding" gpr-query-show-overriding t]
416 ;; ["Show overridden" gpr-query-show-overridden t]
417 ["Refresh cross reference cache" gpr-query-refresh t]
420 (define-minor-mode gpr-query
421 "Minor mode for navigating sources using GNAT cross reference tool.
422 Enable mode if ARG is positive."
424 :lighter " gpr-query" ;; mode line
426 ;; just enable the menu and keymap
429 ;;;;; support for Ada mode
431 (defun gpr-query-refresh ()
432 "For `ada-xref-refresh-function', using gpr_query."
434 ;; need to kill session to get changed env vars etc
435 (let ((session (gpr-query-cached-session)))
436 (gpr-query-kill-session session)
437 (gpr-query--start-process session)))
439 (defun gpr-query-other (identifier file line col)
440 "For `ada-xref-other-function', using gpr_query."
441 (when (eq ?\" (aref identifier 0))
442 ;; gpr_query wants the quotes stripped
444 (setq identifier (substring identifier 1 (1- (length identifier))))
447 (when (eq system-type 'windows-nt)
448 ;; Since Windows file system is case insensitive, GNAT and Emacs
449 ;; can disagree on the case, so convert all to lowercase.
450 (setq file (downcase file)))
452 (let ((cmd (format "refs %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
456 (min-distance (1- (expt 2 29)))
459 (with-current-buffer (gpr-query-session-send cmd t)
460 ;; 'gpr_query refs' returns a list containing the declaration,
461 ;; the body, and all the references, in no particular order.
463 ;; We search the list, looking for the input location,
464 ;; declaration and body, then return the declaration or body as
467 ;; the format of each line is file:line:column (type)
473 ;; full declaration (for a private type)
474 ;; implicit reference
478 ;; Module_Type:/home/Projects/GDS/work_stephe_2/common/1553/gds-hardware-bus_1553-wrapper.ads:171:9 (full declaration)
480 ;; itc_assert:/home/Projects/GDS/work_stephe_2/common/itc/opsim/itc_dscovr_gdsi/Gds1553/src/Gds1553.cpp:830:9 (reference)
482 (message "parsing result ...")
484 (goto-char (point-min))
488 ((looking-at gpr-query-ident-file-type-regexp)
490 (let* ((found-file (match-string 1))
491 (found-line (string-to-number (match-string 2)))
492 (found-col (string-to-number (match-string 3)))
493 (found-type (match-string 4))
494 (dist (gpr-query-dist found-line line found-col col))
497 (when (eq system-type 'windows-nt)
498 ;; 'expand-file-name' converts Windows directory
499 ;; separators to normal Emacs. Since Windows file
500 ;; system is case insensitive, GNAT and Emacs can
501 ;; disagree on the case, so convert all to lowercase.
502 (setq found-file (downcase (expand-file-name found-file))))
504 (when (string-equal found-type "declaration")
505 (setq decl-loc (list found-file found-line (1- found-col))))
508 (string-equal found-type "body")
509 (string-equal found-type "full declaration"))
510 (setq body-loc (list found-file found-line (1- found-col))))
513 ;; The source may have changed since the xref database
514 ;; was computed, so allow for fuzzy matches.
515 (and (equal found-file file)
516 (< dist min-distance))
517 (setq min-distance dist)
518 (setq search-type found-type))
523 ;; This skips GPR_PROJECT_PATH and echoed command at start of buffer.
525 ;; It also skips warning lines. For example,
526 ;; gnatcoll-1.6w-20130902 can't handle the Auto_Text_IO
527 ;; language, because it doesn't use the gprconfig
528 ;; configuration project. That gives lines like:
530 ;; common_text_io.gpr:15:07: language unknown for "gds-hardware-bus_1553-time_tone.ads"
532 ;; There are probably other warnings that might be reported as well.
543 (string-equal search-type "declaration")
545 (setq result body-loc))
548 (setq result decl-loc))
552 (error "gpr_query did not return other item; refresh?"))
554 (message "parsing result ... done")
557 (defun gpr-query-all (identifier file line col)
558 "For `ada-xref-all-function', using gpr_query."
559 (gpr-query-compilation identifier file line col "refs" 'gpr-query-ident-file))
561 (defun gpr-query-parents (identifier file line col)
562 "For `ada-xref-parent-function', using gpr_query."
563 (gpr-query-compilation identifier file line col "parent_types" 'gpr-query-ident-file))
565 (defun gpr-query-overriding (identifier file line col)
566 "For `ada-xref-overriding-function', using gpr_query."
567 (gpr-query-compilation identifier file line col "overriding" 'gpr-query-ident-file))
569 (defun gpr-query-overridden-1 (identifier file line col)
570 "For `ada-xref-overridden-function', using gpr_query."
571 (when (eq ?\" (aref identifier 0))
572 ;; gpr_query wants the quotes stripped
574 (setq identifier (substring identifier 1 (1- (length identifier))))
577 (let ((cmd (format "overridden %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
579 (with-current-buffer (gpr-query-session-send cmd t)
581 (goto-char (point-min))
582 (when (looking-at gpr-query-ident-file-regexp)
586 (string-to-number (match-string 2))
587 (string-to-number (match-string 3)))))
590 (error "gpr_query did not return a result; refresh?"))
592 (message "parsing result ... done")
595 (defun ada-gpr-query-select-prj ()
596 (setq ada-file-name-from-ada-name 'ada-gnat-file-name-from-ada-name)
597 (setq ada-ada-name-from-file-name 'ada-gnat-ada-name-from-file-name)
598 (setq ada-make-package-body 'ada-gnat-make-package-body)
600 (setq ada-xref-refresh-function 'gpr-query-refresh)
601 (setq ada-xref-all-function 'gpr-query-all)
602 (setq ada-xref-other-function 'gpr-query-other)
603 (setq ada-xref-parent-function 'gpr-query-parents)
604 (setq ada-xref-all-function 'gpr-query-all)
605 (setq ada-xref-overriding-function 'gpr-query-overriding)
606 (setq ada-xref-overridden-function 'gpr-query-overridden-1)
607 (setq ada-show-xref-tool-buffer 'gpr-query-show-buffer)
609 (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files, used for cross reference
612 (defun ada-gpr-query-deselect-prj ()
613 (setq ada-file-name-from-ada-name nil)
614 (setq ada-ada-name-from-file-name nil)
615 (setq ada-make-package-body nil)
617 (setq ada-xref-other-function nil)
618 (setq ada-xref-parent-function nil)
619 (setq ada-xref-all-function nil)
620 (setq ada-xref-overriding-function nil)
621 (setq ada-xref-overridden-function nil)
622 (setq ada-show-xref-tool-buffer nil)
624 (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
627 (defun ada-gpr-query ()
628 "Set Ada mode global vars to use gpr_query."
629 (add-to-list 'ada-prj-parser-alist '("gpr" . gnat-parse-gpr))
630 (add-to-list 'ada-select-prj-xref-tool '(gpr_query . ada-gpr-query-select-prj))
631 (add-to-list 'ada-deselect-prj-xref-tool '(gpr_query . ada-gpr-query-deselect-prj))
637 (provide 'ada-xref-tool)
639 (add-to-list 'compilation-error-regexp-alist-alist
640 (cons 'gpr-query-ident-file gpr-query-ident-file-regexp-alist))
642 (unless (and (boundp 'ada-xref-tool)
643 (default-value 'ada-xref-tool))
644 (setq ada-xref-tool 'gpr_query))