1 ;;; gpr-query.el --- minor-mode for navigating sources using the
2 ;;; custom gpr_query tool.
4 ;;; gpr-query supports Ada and any gcc language that supports the
5 ;;; AdaCore -fdump-xref switch (which includes C, C++).
7 ;;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
9 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
10 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
13 ;; This file is part of GNU Emacs.
15 ;; GNU Emacs is free software: you can redistribute it and/or modify
16 ;; it under the terms of the GNU General Public License as published by
17 ;; the Free Software Foundation, either version 3 of the License, or
18 ;; (at your option) any later version.
20 ;; GNU Emacs is distributed in the hope that it will be useful,
21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23 ;; GNU General Public License for more details.
25 ;; You should have received a copy of the GNU General Public License
26 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
32 (require 'ada-mode) ;; for ada-prj-*, some other things
39 ;; gpr_query reads the project files and the database at startup,
40 ;; which is noticeably slow for a reasonably sized project. But
41 ;; running queries after startup is fast. So we leave gpr_query
42 ;; running, and send it new queries via stdin, getting responses via
45 ;; We maintain a cache of active sessions, one per gnat project.
47 (cl-defstruct (gpr-query--session)
48 (process nil) ;; running gpr_query
49 (buffer nil)) ;; receives output of gpr_query
51 (defconst gpr-query-buffer-name-prefix " *gpr_query-")
53 (defun gpr-query--start-process (session)
54 "Start the session process running gpr_query."
55 (unless (buffer-live-p (gpr-query--session-buffer session))
56 ;; user may have killed buffer
57 (setf (gpr-query--session-buffer session) (gnat-run-buffer gpr-query-buffer-name-prefix)))
59 (with-current-buffer (gpr-query--session-buffer session)
60 (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
62 (project-file (file-name-nondirectory (ada-prj-get 'gpr_file))))
63 (erase-buffer); delete any previous messages, prompt
64 (setf (gpr-query--session-process session)
65 ;; gnatcoll-1.6 can't handle aggregate projects; M910-032
66 ;; gpr_query can handle some aggregate projects, but not all
67 ;; FIXME: need good error message on bad project file:
68 ;; "can't handle aggregate projects?")
69 (start-process (concat "gpr_query " (buffer-name))
70 (gpr-query--session-buffer session)
72 (concat "--project=" project-file)))
73 (set-process-query-on-exit-flag (gpr-query--session-process session) nil)
74 (gpr-query-session-wait session)
76 ;; check for warnings about invalid directories etc
77 (goto-char (point-min))
78 (when (search-forward "warning:" nil t)
79 (error "gpr_query warnings"))
82 (defun gpr-query--make-session ()
83 "Create and return a session for the current project file."
85 (make-gpr-query--session
86 :buffer (gnat-run-buffer gpr-query-buffer-name-prefix))))
87 (gpr-query--start-process session)
90 (defvar gpr-query--sessions '()
91 "Assoc list of sessions, indexed by absolute GNAT project file name.")
93 (defun gpr-query-cached-session ()
94 "Return a session for the current project file, creating it if necessary."
95 (let* ((session (cdr (assoc ada-prj-current-file gpr-query--sessions))))
98 (unless (process-live-p (gpr-query--session-process session))
99 (gpr-query--start-process session))
103 (setq session (gpr-query--make-session))
104 (setq gpr-query--sessions
105 (cl-acons ada-prj-current-file session gpr-query--sessions))))
108 (defconst gpr-query-prompt "^>>> $"
109 ;; gpr_query output ends with this
110 "Regexp matching gpr_query prompt; indicates previous command is complete.")
112 (defun gpr-query-session-wait (session)
113 "Wait for the current command to complete."
114 (unless (process-live-p (gpr-query--session-process session))
115 (gpr-query-show-buffer session)
116 (error "gpr-query process died"))
118 (with-current-buffer (gpr-query--session-buffer session)
119 (let ((process (gpr-query--session-process session))
120 (search-start (point-min))
122 (while (and (process-live-p process)
124 ;; process output is inserted before point, so move back over it to search it
125 (goto-char search-start)
126 (not (re-search-forward gpr-query-prompt (point-max) 1))))
127 (setq search-start (point));; don't search same text again
128 (message (concat "running gpr_query ..." (make-string wait-count ?.)))
129 ;; FIXME: use --display-progress
130 (accept-process-output process 1.0)
131 (setq wait-count (1+ wait-count)))
132 (if (process-live-p process)
133 (message (concat "running gpr_query ... done"))
134 (gpr-query-show-buffer session)
135 (error "gpr_query process died"))
138 (defun gpr-require-prj ()
139 "Throw error if no project file defined."
140 (unless (or (ada-prj-get 'gpr_file)
141 (ada-prj-get 'gpr_query_file))
142 (error "no gpr project file defined.")))
144 (defun gpr-query-session-send (cmd wait)
145 "Send CMD to gpr_query session for current project.
146 If WAIT is non-nil, wait for command to complete.
147 Return buffer that holds output."
149 (let ((session (gpr-query-cached-session)))
150 ;; always wait for previous command to complete; also checks for
152 (gpr-query-session-wait session)
153 (with-current-buffer (gpr-query--session-buffer session)
155 (process-send-string (gpr-query--session-process session)
158 (gpr-query-session-wait session))
162 (defun gpr-query-kill-session (session)
163 (let ((process (gpr-query--session-process session)))
164 (when (process-live-p process)
165 (process-send-string (gpr-query--session-process session) "exit\n")
166 (while (process-live-p process)
167 (accept-process-output process 1.0)))
170 (defun gpr-query-kill-all-sessions ()
173 (mapc (lambda (assoc)
174 (let ((session (cdr assoc)))
175 (when (process-live-p (gpr-query--session-process session))
176 (setq count (1+ count))
177 (process-send-string (gpr-query--session-process session) "exit\n")
180 (message "Killed %d sessions" count)
183 (defun gpr-query-show-buffer (&optional session)
184 "For `ada-show-xref-tool-buffer'; show gpr-query buffer for current project."
186 (pop-to-buffer (gpr-query--session-buffer (or session (gpr-query-cached-session)))))
190 (defun gpr-query-get-src-dirs (src-dirs)
191 "Append list of source dirs in current gpr project to SRC-DIRS.
192 Uses 'gpr_query'. Returns new list."
194 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
195 (gpr-query-session-send "source_dirs" t)
196 (goto-char (point-min))
197 (while (not (looking-at gpr-query-prompt))
198 (cl-pushnew (directory-file-name
199 (buffer-substring-no-properties (point) (point-at-eol)))
200 src-dirs :test #'equal)
205 (defun gpr-query-get-prj-dirs (prj-dirs)
206 "Append list of source dirs in current gpr project to PRJ-DIRS.
207 Uses 'gpr_query'. Returns new list."
209 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
210 (gpr-query-session-send "project_path" t)
211 (goto-char (point-min))
212 (while (not (looking-at gpr-query-prompt))
213 (cl-pushnew (directory-file-name
214 (buffer-substring-no-properties (point) (point-at-eol)))
215 prj-dirs :test #'equal)
220 (defconst gpr-query-ident-file-regexp
221 ;; C:\Projects\GDS\work_dscovr_release\common\1553\gds-mil_std_1553-utf.ads:252:25
222 ;; /Projects/GDS/work_dscovr_release/common/1553/gds-mil_std_1553-utf.ads:252:25
223 "\\(\\(?:.:\\\|/\\)[^:]*\\):\\([0123456789]+\\):\\([0123456789]+\\)"
225 "Regexp matching <file>:<line>:<column>")
227 (defconst gpr-query-ident-file-regexp-alist
228 (list (concat "^" gpr-query-ident-file-regexp) 1 2 3)
229 "For compilation-error-regexp-alist, matching gpr_query output")
231 (defconst gpr-query-ident-file-type-regexp
232 (concat gpr-query-ident-file-regexp " (\\(.*\\))")
233 "Regexp matching <file>:<line>:<column> (<type>)")
236 ;; in *compilation-gpr_query-refs*, run
237 ;; (progn (set-text-properties (point-min)(point-max) nil)(compilation-parse-errors (point-min)(point-max) gpr-query-ident-file-regexp-alist))
239 (defun gpr-query-compilation (identifier file line col cmd comp-err)
240 "Run gpr_query IDENTIFIER:FILE:LINE:COL CMD,
241 set compilation-mode with compilation-error-regexp-alist set to COMP-ERR."
242 ;; Useful when gpr_query will return a list of references; we use
243 ;; `compilation-start' to run gpr_query, so the user can navigate
244 ;; to each result in turn via `next-error'.
245 (let ((cmd-1 (format "%s %s:%s:%d:%d" cmd identifier file line col))
248 (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
250 (setq buffer-read-only nil)
251 (set (make-local-variable 'compilation-error-regexp-alist) (list comp-err))
252 (gpr-query-session-send cmd-1 t)
253 ;; point is at EOB. gpr_query returns one line per result plus prompt
254 (setq result-count (- (line-number-at-pos) 1))
255 ;; Won't be needed in 24.5 any more.
256 (if (fboundp 'font-lock-ensure)
258 (font-lock-fontify-buffer))
259 ;; font-lock-fontify-buffer applies compilation-message text properties
260 ;; FIXME: Won't be needed in 24.5 any more, since compilation-next-error
261 ;; will apply compilation-message text properties on the fly.
262 ;; IMPROVEME: for some reason, next-error works, but the font
263 ;; colors are not right (no koolaid!)
264 (goto-char (point-min))
266 (cl-case result-count
268 (error "gpr_query returned no results"))
270 (when (looking-at "^Error: entity not found")
271 (error (buffer-substring-no-properties (line-beginning-position) (line-end-position))))
273 ;; just go there, don't display session-buffer. We have to
274 ;; fetch the compilation-message while in the session-buffer.
275 (let* ((msg (compilation-next-error 0 nil (point-min)))
276 ;; FIXME: '--' indicates internal-only; use compile-goto-error
277 (loc (compilation--message->loc msg)))
278 (setq file (caar (compilation--loc->file-struct loc))
279 line (caar (cddr (compilation--loc->file-struct loc)))
280 column (1- (compilation--loc->col loc)))
284 ;; for next-error, below
285 (setq next-error-last-buffer (current-buffer)))
287 ));; case, with-currrent-buffer
289 (if (> result-count 1)
290 ;; more than one result; display session buffer, goto first ref
292 ;; compilation-next-error-function assumes there is not an error
293 ;; at point-min; work around that by moving forward 0 errors for
294 ;; the first one. Unless the first line contains "warning: ".
295 (if (looking-at "^warning: ")
299 ;; just one result; go there
300 (ada-goto-source file line column nil))
303 (defun gpr-query-dist (found-line line found-col col)
304 "Return distance between FOUND-LINE FOUND-COL and LINE COL."
305 (+ (abs (- found-col col))
306 (* (abs (- found-line line)) 250)))
308 ;;;;; user interface functions
310 (defun gpr-query-show-references ()
311 "Show all references of identifier at point."
314 (thing-at-point 'symbol)
315 (file-name-nondirectory (buffer-file-name))
317 (1+ (current-column)))
320 (defun gpr-query-overridden (other-window)
321 "Move to the overridden declaration of the identifier around point.
322 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
323 buffer in another window."
327 (gpr-query-overridden-1
328 (thing-at-point 'symbol)
332 (goto-char (car (bounds-of-thing-at-point 'symbol)))
333 (1+ (current-column)))
336 (ada-goto-source (nth 0 target)
342 (defun gpr-query-goto-declaration (other-window)
343 "Move to the declaration or body of the identifier around point.
344 If at the declaration, go to the body, and vice versa. If at a
345 reference, goto the declaration.
347 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
348 buffer in another window."
353 (thing-at-point 'symbol)
357 (goto-char (car (bounds-of-thing-at-point 'symbol)))
358 (1+ (current-column)))
361 (ada-goto-source (nth 0 target)
367 (defvar gpr-query-map
368 (let ((map (make-sparse-keymap)))
369 ;; C-c C-i prefix for gpr-query minor mode
371 (define-key map "\C-c\C-i\C-d" 'gpr-query-goto-declaration)
372 (define-key map "\C-c\C-i\C-p" 'ada-build-prompt-select-prj-file)
373 (define-key map "\C-c\C-i\C-q" 'gpr-query-refresh)
374 (define-key map "\C-c\C-i\C-r" 'gpr-query-show-references)
375 ;; FIXME: (define-key map "\C-c\M-d" 'gpr-query-parents)
378 ) "Local keymap used for gpr query minor mode.")
380 (defvar gpr-query-menu (make-sparse-keymap "gpr-query"))
381 (easy-menu-define gpr-query-menu gpr-query-map "Menu keymap for gpr-query minor mode"
383 ["Find and select project ..." ada-build-prompt-select-prj-file t]
384 ["Select project ..." ada-prj-select t]
385 ["Show current project" ada-prj-show t]
386 ["Show gpr-query buffer" gpr-query-show-buffer t]
387 ["Next compilation error" next-error t]
388 ["Show secondary error" ada-show-secondary-error t]
389 ["Goto declaration/body" gpr-query-goto-declaration t]
390 ["Show parent declarations" ada-show-declaration-parents t]
391 ["Show references" gpr-query-show-references t]
392 ;; ["Show overriding" gpr-query-show-overriding t]
393 ;; ["Show overridden" gpr-query-show-overridden t]
394 ["Refresh cross reference cache" gpr-query-refresh t]
397 (define-minor-mode gpr-query
398 "Minor mode for navigating sources using GNAT cross reference tool.
399 Enable mode if ARG is positive"
401 :lighter " gpr-query" ;; mode line
403 ;; just enable the menu and keymap
406 ;;;;; support for Ada mode
408 (defun gpr-query-refresh ()
409 "For `ada-xref-refresh-function', using gpr_query."
411 ;; need to kill session to get changed env vars etc
412 (let ((session (gpr-query-cached-session)))
413 (gpr-query-kill-session session)
414 (gpr-query--start-process session)))
416 (defun gpr-query-other (identifier file line col)
417 "For `ada-xref-other-function', using gpr_query."
418 (when (eq ?\" (aref identifier 0))
419 ;; gpr_query wants the quotes stripped
421 (setq identifier (substring identifier 1 (1- (length identifier))))
424 (when (eq system-type 'windows-nt)
425 ;; Since Windows file system is case insensitive, GNAT and Emacs
426 ;; can disagree on the case, so convert all to lowercase.
427 (setq file (downcase file)))
429 (let ((cmd (format "refs %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
433 (min-distance (1- (expt 2 29)))
436 (with-current-buffer (gpr-query-session-send cmd t)
437 ;; 'gpr_query refs' returns a list containing the declaration,
438 ;; the body, and all the references, in no particular order.
440 ;; We search the list, looking for the input location,
441 ;; declaration and body, then return the declaration or body as
444 ;; the format of each line is file:line:column (type)
450 ;; full declaration (for a private type)
451 ;; implicit reference
455 ;; Module_Type:/home/Projects/GDS/work_stephe_2/common/1553/gds-hardware-bus_1553-wrapper.ads:171:9 (full declaration)
457 ;; itc_assert:/home/Projects/GDS/work_stephe_2/common/itc/opsim/itc_dscovr_gdsi/Gds1553/src/Gds1553.cpp:830:9 (reference)
459 (message "parsing result ...")
461 (goto-char (point-min))
465 ((looking-at gpr-query-ident-file-type-regexp)
467 (let* ((found-file (match-string 1))
468 (found-line (string-to-number (match-string 2)))
469 (found-col (string-to-number (match-string 3)))
470 (found-type (match-string 4))
471 (dist (gpr-query-dist found-line line found-col col))
474 (when (eq system-type 'windows-nt)
475 ;; 'expand-file-name' converts Windows directory
476 ;; separators to normal Emacs. Since Windows file
477 ;; system is case insensitive, GNAT and Emacs can
478 ;; disagree on the case, so convert all to lowercase.
479 (setq found-file (downcase (expand-file-name found-file))))
481 (when (string-equal found-type "declaration")
482 (setq decl-loc (list found-file found-line (1- found-col))))
485 (string-equal found-type "body")
486 (string-equal found-type "full declaration"))
487 (setq body-loc (list found-file found-line (1- found-col))))
490 ;; The source may have changed since the xref database
491 ;; was computed, so allow for fuzzy matches.
492 (and (equal found-file file)
493 (< dist min-distance))
494 (setq min-distance dist)
495 (setq search-type found-type))
500 ;; This skips GPR_PROJECT_PATH and echoed command at start of buffer.
502 ;; It also skips warning lines. For example,
503 ;; gnatcoll-1.6w-20130902 can't handle the Auto_Text_IO
504 ;; language, because it doesn't use the gprconfig
505 ;; configuration project. That gives lines like:
507 ;; common_text_io.gpr:15:07: language unknown for "gds-hardware-bus_1553-time_tone.ads"
509 ;; There are probably other warnings that might be reported as well.
520 (string-equal search-type "declaration")
522 (setq result body-loc))
525 (setq result decl-loc))
529 (error "gpr_query did not return other item; refresh?"))
531 (message "parsing result ... done")
534 (defun gpr-query-all (identifier file line col)
535 "For `ada-xref-all-function', using gpr_query."
536 (gpr-query-compilation identifier file line col "refs" 'gpr-query-ident-file))
538 (defun gpr-query-parents (identifier file line col)
539 "For `ada-xref-parent-function', using gpr_query."
540 (gpr-query-compilation identifier file line col "parent_types" 'gpr-query-ident-file))
542 (defun gpr-query-overriding (identifier file line col)
543 "For `ada-xref-overriding-function', using gpr_query."
544 (gpr-query-compilation identifier file line col "overriding" 'gpr-query-ident-file))
546 (defun gpr-query-overridden-1 (identifier file line col)
547 "For `ada-xref-overridden-function', using gpr_query."
548 (when (eq ?\" (aref identifier 0))
549 ;; gpr_query wants the quotes stripped
551 (setq identifier (substring identifier 1 (1- (length identifier))))
554 (let ((cmd (format "overridden %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
556 (with-current-buffer (gpr-query-session-send cmd t)
558 (goto-char (point-min))
559 (when (looking-at gpr-query-ident-file-regexp)
563 (string-to-number (match-string 2))
564 (string-to-number (match-string 3)))))
567 (error "gpr_query did not return a result; refresh?"))
569 (message "parsing result ... done")
572 (defun ada-gpr-query-select-prj ()
573 (setq ada-file-name-from-ada-name 'ada-gnat-file-name-from-ada-name)
574 (setq ada-ada-name-from-file-name 'ada-gnat-ada-name-from-file-name)
575 (setq ada-make-package-body 'ada-gnat-make-package-body)
577 (add-hook 'ada-syntax-propertize-hook 'gnatprep-syntax-propertize)
579 ;; must be after indentation engine setup, because that resets the
580 ;; indent function list.
581 (add-hook 'ada-mode-hook 'ada-gpr-query-setup t)
583 (setq ada-xref-refresh-function 'gpr-query-refresh)
584 (setq ada-xref-all-function 'gpr-query-all)
585 (setq ada-xref-other-function 'gpr-query-other)
586 (setq ada-xref-parent-function 'gpr-query-parents)
587 (setq ada-xref-all-function 'gpr-query-all)
588 (setq ada-xref-overriding-function 'gpr-query-overriding)
589 (setq ada-xref-overridden-function 'gpr-query-overridden-1)
590 (setq ada-show-xref-tool-buffer 'gpr-query-show-buffer)
592 (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files, used for cross reference
595 (defun ada-gpr-query-deselect-prj ()
596 (setq ada-file-name-from-ada-name nil)
597 (setq ada-ada-name-from-file-name nil)
598 (setq ada-make-package-body nil)
600 (setq ada-syntax-propertize-hook (delq 'gnatprep-syntax-propertize ada-syntax-propertize-hook))
601 (setq ada-mode-hook (delq 'ada-gpr-query-setup ada-mode-hook))
603 (setq ada-xref-other-function nil)
604 (setq ada-xref-parent-function nil)
605 (setq ada-xref-all-function nil)
606 (setq ada-xref-overriding-function nil)
607 (setq ada-xref-overridden-function nil)
608 (setq ada-show-xref-tool-buffer nil)
610 (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
613 (defun ada-gpr-query-setup ()
614 (when (boundp 'wisi-indent-calculate-functions)
615 (add-to-list 'wisi-indent-calculate-functions 'gnatprep-indent))
618 (defun ada-gpr-query ()
619 "Set Ada mode global vars to use gpr_query."
620 (add-to-list 'ada-prj-parser-alist '("gpr" . gnat-parse-gpr))
621 (add-to-list 'ada-select-prj-xref-tool '(gpr_query . ada-gpr-query-select-prj))
622 (add-to-list 'ada-deselect-prj-xref-tool '(gpr_query . ada-gpr-query-deselect-prj))
626 (font-lock-add-keywords 'ada-mode
627 ;; gnatprep preprocessor line
628 (list (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-preprocessor-face t))))
632 (provide 'ada-xref-tool)
634 (add-to-list 'compilation-error-regexp-alist-alist
635 (cons 'gpr-query-ident-file gpr-query-ident-file-regexp-alist))
637 (unless (and (boundp 'ada-xref-tool)
638 (default-value 'ada-xref-tool))
639 (setq ada-xref-tool 'gpr_query))