Merge branch 'dgud/tools/emacs-xref/PR-1051'

* dgud/tools/emacs-xref/PR-1051:
  Add xref support in erlang.el

Conflicts:
	lib/tools/emacs/erlang.el

2 files changed, 302 insertions, 54 deletions

diff --git a/lib/tools/emacs/erlang-test.el b/lib/tools/emacs/erlang-test.el
new file mode 100644
index 0000000000..a5aab04953
--- /dev/null
+++ b/lib/tools/emacs/erlang-test.el
@@ -0,0 +1,107 @@
+;;; erlang-test.el -*- lexical-binding: t; coding: utf-8-unix -*-
+
+;;; Unit tests for erlang.el.
+
+;; Author:   Johan Claesson
+;; Created: 2016-05-07
+;; Keywords: erlang, languages
+
+;; %CopyrightBegin%
+;;
+;; Copyright Ericsson AB 2016. All Rights Reserved.
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License");
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+;;
+;; %CopyrightEnd%
+
+
+;;; Commentary:
+
+;; This library require GNU Emacs 25 or later.
+
+;;; Code:
+
+(require 'ert)
+(require 'cl-lib)
+
+(defvar erlang-test-code
+  '((nil . "-module(erlang_test).")
+    (nil . "-import(lists, [map/2]).")
+    (nil . "-compile(export_all).")
+    ("SYMBOL" . "-define(SYMBOL, value).")
+    ("MACRO" . "-define(MACRO(X), X + X).")
+    ("struct" . "-record(struct, {until,maps,are,everywhere}).")
+    ("function". "function() -> #struct{}."))
+  "Alist of erlang test code.
+Each entry have the format (TAGNAME . ERLANG_CODE).  If TAGNAME
+is nil there is no definitions in the ERLANG_CODE.  The
+ERLANG_CODE is a single line of erlang code.  These lines will be
+concatenated to form an erlang file to test on.")
+
+
+(ert-deftest erlang-test-tags ()
+  (let* ((dir (make-temp-file "erlang-test" t))
+         (erlang-file (expand-file-name "erlang_test.erl" dir))
+         (tags-file (expand-file-name "TAGS" dir))
+         tags-file-name tags-table-list erlang-buffer)
+    (unwind-protect
+        (progn
+          (erlang-test-create-erlang-file erlang-file)
+          (erlang-test-compile-tags erlang-file tags-file)
+          (setq erlang-buffer (find-file-noselect erlang-file))
+          (with-current-buffer erlang-buffer
+            (setq-local tags-file-name tags-file))
+          ;; PENDING - setting global tags-file-name is a workaround
+          ;; for GNU Emacs bug23164.
+          (setq tags-file-name tags-file)
+          (erlang-test-xref-find-definitions erlang-file erlang-buffer))
+      (when (buffer-live-p erlang-buffer)
+        (kill-buffer erlang-buffer))
+      (let ((tags-buffer (find-buffer-visiting tags-file)))
+        (when (buffer-live-p tags-buffer)
+          (kill-buffer tags-buffer)))
+      (when (file-exists-p dir)
+        (delete-directory dir t)))))
+
+(defun erlang-test-create-erlang-file (erlang-file)
+  (with-temp-file erlang-file
+    (cl-loop for (_ . code) in erlang-test-code
+             do (insert code "\n"))))
+
+(defun erlang-test-compile-tags (erlang-file tags-file)
+  (should (zerop (call-process "etags" nil nil nil
+                               "-o" tags-file
+                               erlang-file))))
+
+(defun erlang-test-xref-find-definitions (erlang-file erlang-buffer)
+  (cl-loop for (tagname . code) in erlang-test-code
+           for line = 1 then (1+ line)
+           do (when tagname
+                (switch-to-buffer erlang-buffer)
+                (xref-find-definitions tagname)
+                (erlang-test-verify-pos erlang-file line)
+                (xref-find-definitions (concat "erlang_test:" tagname))
+                (erlang-test-verify-pos erlang-file line)))
+  (xref-find-definitions "erlang_test:")
+  (erlang-test-verify-pos erlang-file 1))
+
+(defun erlang-test-verify-pos (expected-file expected-line)
+  (should (string-equal (file-truename expected-file)
+                        (file-truename (buffer-file-name))))
+  (should (eq expected-line (line-number-at-pos)))
+  (should (= (point-at-bol) (point))))
+
+
+(provide 'erlang-test)
+
+;;; erlang-test.el ends here
diff --git a/lib/tools/emacs/erlang.el b/lib/tools/emacs/erlang.el
index 4f656e3ae4..aff2c4b2c9 100644
--- a/lib/tools/emacs/erlang.el
+++ b/lib/tools/emacs/erlang.el
@@ -70,8 +70,8 @@
 ;; `debug-on-error' to `t'.  Repeat the error and enclose the debug
 ;; information in your bug-report.
 ;;
-;; To set the variable you can use the following command:
-;;     M-x set-variable RET debug-on-error RET t RET
+;; To toggle the variable you can use the following command:
+;;     M-x toggle-debug-on-error RET
 ;;; Code:
 
 (eval-when-compile (require 'cl))
@@ -1068,8 +1068,14 @@ behaviour.")
   "Font lock keyword highlighting a function header.")
 
 (defface erlang-font-lock-exported-function-name-face
-  '((default (:inherit font-lock-function-name-face)))
-  "Face used for highlighting exported functions.")
+  (if (featurep 'xemacs)
+      (progn
+        (require 'font-lock)
+        `((t (:foreground ,(face-foreground 'font-lock-function-name-face))
+             (:background ,(face-background 'font-lock-function-name-face)))))
+    '((default (:inherit font-lock-function-name-face))))
+  "Face used for highlighting exported functions."
+  :group 'erlang)
 
 (defvar erlang-font-lock-exported-function-name-face
   'erlang-font-lock-exported-function-name-face)
@@ -1338,11 +1344,15 @@ Lock syntax table.  The effect is that `apply' in the atom
 (defun erlang-version ()
   "Return the current version of Erlang mode."
   (interactive)
-  (if (interactive-p)
+  (if (erlang-interactive-p)
       (message "Erlang mode version %s, written by Anders Lindgren"
 	       erlang-version))
   erlang-version)
 
+(defun erlang-interactive-p ()
+  (if (fboundp 'called-interactively-p)
+      (called-interactively-p 'interactive)
+    (funcall (symbol-function 'interactive-p))))
 
 ;;;###autoload
 (define-derived-mode erlang-mode prog-mode "Erlang"
@@ -1415,7 +1425,11 @@ Other commands:
   (erlang-tags-init)
   (erlang-font-lock-init)
   (erlang-skel-init)
-  (tempo-use-tag-list 'erlang-tempo-tags)
+  (when (fboundp 'tempo-use-tag-list)
+    (tempo-use-tag-list 'erlang-tempo-tags))
+  (when (boundp 'xref-backend-functions)
+    (add-hook 'xref-backend-functions #'erlang-etags--xref-backend nil t))
+  (run-hooks 'erlang-mode-hook)
   (if (zerop (buffer-size))
       (run-hooks 'erlang-new-file-hook)))
 
@@ -1536,7 +1550,9 @@ Other commands:
 	      table)))
   (set (make-local-variable 'font-lock-syntax-table)
        erlang-font-lock-syntax-table)
-  (set (make-local-variable 'font-lock-beginning-of-syntax-function)
+  (set (make-local-variable (if (boundp 'syntax-begin-function)
+                                'syntax-begin-function
+                              'font-lock-beginning-of-syntax-function))
        'erlang-beginning-of-clause)
   (make-local-variable 'font-lock-keywords)
   (let ((level (cond ((boundp 'font-lock-maximum-decoration)
@@ -2244,6 +2260,7 @@ mode with the command `M-x erlang-mode RET'.")))
 ;; This code is based on the package `tempo' which is part of modern
 ;; Emacsen.  (GNU Emacs 19.25 (?) and XEmacs 19.14.)
 
+(defvar erlang-skel)
 (defun erlang-skel-init ()
   "Generate the skeleton functions and menu items.
 The variable `erlang-skel' contains the name and descriptions of
@@ -3813,20 +3830,19 @@ exported function."
 (defun erlang-check-module-name-init ()
   "Initialize the functionality to compare file and module names.
 
-Unless we have `before-save-hook', we redefine the function
+Unless we have `before-save-hook', we advice the function
 `set-visited-file-name' since it clears the variable
-`local-write-file-hooks'.  The original function definition is
-stored in `erlang-orig-set-visited-file-name'."
+`local-write-file-hooks'."
   (if (boundp 'before-save-hook)
-      ;; If we have that, `make-local-hook' is obsolete.
       (add-hook 'before-save-hook 'erlang-check-module-name nil t)
     (require 'advice)
-    (unless (ad-advised-definition-p 'set-visited-file-name)
-      (defadvice set-visited-file-name (after erlang-set-visited-file-name
-					      activate)
-	(if (eq major-mode 'erlang-mode)
-	    (add-hook 'local-write-file-hooks 'erlang-check-module-name))))
-    (add-hook 'local-write-file-hooks 'erlang-check-module-name)))
+    (when (fboundp 'ad-advised-definition-p)
+      (unless (ad-advised-definition-p 'set-visited-file-name)
+        (defadvice set-visited-file-name (after erlang-set-visited-file-name
+                                                activate)
+          (if (eq major-mode 'erlang-mode)
+              (add-hook 'local-write-file-hooks 'erlang-check-module-name))))
+      (add-hook 'local-write-file-hooks 'erlang-check-module-name))))
 
 
 (defun erlang-check-module-name ()
@@ -3903,7 +3919,7 @@ non-whitespace characters following the point on the current line."
     (newline)
     (if (condition-case nil
 	    (progn (erlang-indent-line) t)
-	  (error (if (bolp) (delete-backward-char 1))))
+	  (error (if (bolp) (delete-char -1))))
 	(if (not (bolp))
 	    (save-excursion
 	      (insert " ->"))
@@ -3915,7 +3931,7 @@ non-whitespace characters following the point on the current line."
 		      (beginning-of-line)
 		      (newline
 		       erlang-electric-semicolon-insert-blank-lines))))
-	    (error (if (bolp) (delete-backward-char 1))))))))
+	    (error (if (bolp) (delete-char -1))))))))
 
 
 (defun erlang-electric-comma (&optional arg)
@@ -3945,7 +3961,7 @@ non-whitespace characters following the point on the current line."
     (newline)
     (condition-case nil
 	(erlang-indent-line)
-      (error (if (bolp) (delete-backward-char 1))))))
+      (error (if (bolp) (delete-char -1))))))
 
 (defun erlang-electric-lt (&optional arg)
   "Insert a less-than sign, and optionally mark it as an open paren."
@@ -4031,7 +4047,7 @@ non-whitespace characters following the point on the current line."
       (newline)
       (condition-case nil
 	  (erlang-indent-line)
-	(error (if (bolp) (delete-backward-char 1))))))
+	(error (if (bolp) (delete-char -1))))))
 
    ;; Then it's just a plain greater-than.
    (t
@@ -4071,7 +4087,7 @@ After being split/merged into `erlang-after-arrow' and
       (newline)
       (condition-case nil
 	  (erlang-indent-line)
-	(error (if (bolp) (delete-backward-char 1)))))))
+	(error (if (bolp) (delete-char -1)))))))
 
 
 (defun erlang-electric-newline (&optional arg)
@@ -4547,6 +4563,11 @@ Tags can be given on the forms `tag', `module:', `module:tag'."
     (current-buffer)))			; Return the new buffer.
 
 
+
+    
+
+
+
 ;; Process interactive arguments for erlang-find-tag-*.
 ;;
 ;; Negative arguments work only for `etags', not `tags'.  This is not
@@ -4747,7 +4768,7 @@ for a tag on the form `module:tag'."
     (and found
 	 (or (null mod)
 	     (string= mod (erlang-get-module-from-file-name
-			   (file-of-tag)))))))
+			   (funcall (symbol-function 'file-of-tag))))))))
 
 
 ;;; Tags completion, Emacs 19 `etags' specific.
@@ -4787,10 +4808,10 @@ about Erlang modules."
   (cond ((and erlang-tags-installed
               (fboundp 'etags-tags-completion-table)
               (fboundp 'tags-lazy-completion-table)) ; Emacs 23.1+
-         ;; This depends on the advice called erlang-replace-tags-table
-         ;; above.  It is not enough to let-bind
-         ;; tags-completion-table-function since that will not override
-         ;; the buffer-local value in the TAGS buffer.
+         ;; This depends on the advice called
+         ;; erlang-replace-tags-table above.  It is not enough to
+         ;; let-bind tags-completion-table-function since that may be
+         ;; overwritten in etags-recognize-tags-table.
          (let ((find-tag-default-function 'erlang-find-tag-for-completion))
            (complete-tag)))
         ((and erlang-tags-installed
@@ -4912,6 +4933,132 @@ about Erlang modules."
             (progress-reporter-update progress-reporter (point))))))
     table))
 
+
+;;; Xref backend erlang-etags
+
+;; In GNU Emacs 25 xref was introduced.  It is a framework for cross
+;; referencing commands, in particular commands for finding
+;; definitions.  It does not replace etags.  It rather resides on top
+;; of it and provides user-friendly commands.  The idea is that the
+;; user commands should be the same regardless of what backend does
+;; the actual finding of definitions.
+
+;; The backend below is a wrapper around the built-in etags backend.
+;; It adds awareness of the module:tag syntax in a similar way that is
+;; done above for the old etags commands.
+
+
+(defun erlang-etags--xref-backend () 'erlang-etags)
+
+(defun erlang-soft-require (feature)
+  (when (locate-library (symbol-name feature))
+    (require feature)))
+
+(and (erlang-soft-require 'xref)
+     (erlang-soft-require 'cl-generic)
+     ;; The purpose of using eval here is to avoid compilation
+     ;; warnings in emacsen without cl-defmethod.
+     (eval
+      '(progn
+         (cl-defmethod xref-backend-identifier-at-point
+             ((_backend (eql erlang-etags)))
+           (erlang-find-tag-default))
+
+         (cl-defmethod xref-backend-definitions
+             ((_backend (eql erlang-etags)) identifier)
+           (erlang-xref-find-definitions identifier))
+
+         (cl-defmethod xref-backend-apropos
+             ((_backend (eql erlang-etags)) identifier)
+           (erlang-xref-find-definitions identifier t))
+
+         ;; PENDING - This remains to be properly implemented.
+         (cl-defmethod xref-backend-identifier-completion-table
+             ((_backend (eql erlang-etags)))
+           (tags-lazy-completion-table)))))
+
+
+(defun erlang-xref-find-definitions (identifier &optional is-regexp)
+  (let ((id-list (split-string identifier ":")))
+    (cond
+     ;; Handle "tag"
+     ((null (cdr id-list))
+      (erlang-xref-find-definitions-tag identifier is-regexp))
+     ;; Handle "module:"
+     ((string-equal (cadr id-list) "")
+      (erlang-xref-find-definitions-module (car id-list)))
+     ;; Handle "module:tag"
+     (t
+      (erlang-xref-find-definitions-module-tag (car id-list)
+                                               (cadr id-list)
+                                               is-regexp)))))
+
+(defun erlang-xref-find-definitions-tag (tag is-regexp)
+  "Find all definitions of TAG and reorder them so that
+definitions in the currently visited file comes first."
+  (when (fboundp 'etags--xref-find-definitions)
+    (let* ((current-file (and (buffer-file-name)
+                              (file-truename (buffer-file-name))))
+           (xrefs (etags--xref-find-definitions tag is-regexp))
+           local-xrefs non-local-xrefs)
+      (while xrefs
+        (if (string-equal (erlang-xref-truename-file (car xrefs))
+                          current-file)
+            (push (car xrefs) local-xrefs)
+          (push (car xrefs) non-local-xrefs))
+        (setq xrefs (cdr xrefs)))
+      (append (reverse local-xrefs)
+              (reverse non-local-xrefs)))))
+
+(defun erlang-xref-find-definitions-module (module)
+  (and (fboundp 'xref-make)
+       (fboundp 'xref-make-file-location)
+       (let* ((first-time t)
+              xrefs matching-files)
+         (save-excursion
+           (while (visit-tags-table-buffer (not first-time))
+             (setq first-time nil)
+             (let ((files (tags-table-files)))
+               (while files
+                 (let* ((file (car files))
+                        (m (erlang-get-module-from-file-name file)))
+                   (when (and m (string-equal m module))
+                     (unless (member file matching-files)
+                       (push file
+                             matching-files)
+                       (push (xref-make file
+                                        (xref-make-file-location file 1 0))
+                             xrefs))))
+                 (setq files (cdr files))))))
+         (nreverse xrefs))))
+
+(defun erlang-xref-find-definitions-module-tag (module tag is-regexp)
+  "Find all definitions of TAG and filter away definitions
+outside of MODULE."
+  (when (fboundp 'etags--xref-find-definitions)
+    (let ((xrefs (etags--xref-find-definitions tag is-regexp))
+          xrefs-in-module)
+      (while xrefs
+        (when (string-equal module (erlang-xref-module (car xrefs)))
+          (push (car xrefs) xrefs-in-module))
+        (setq xrefs (cdr xrefs)))
+      xrefs-in-module)))
+
+(defun erlang-xref-module (xref)
+  (erlang-get-module-from-file-name (erlang-xref-file xref)))
+
+(defun erlang-xref-truename-file (xref)
+  (let ((file (erlang-xref-file xref)))
+    (and file
+         (file-truename file))))
+
+(defun erlang-xref-file (xref)
+  (and (fboundp 'xref-location-group)
+       (fboundp 'xref-item-location)
+       (xref-location-group (xref-item-location xref))))
+
+
+
 ;;;
 ;;; Prepare for other methods to run an Erlang slave process.
 ;;;
@@ -5310,8 +5457,7 @@ frame will become deselected before the next command."
       ()
     (or (inferior-erlang-running-p)
 	(error "No inferior Erlang shell is running"))
-    (save-excursion
-      (set-buffer inferior-erlang-buffer)
+    (with-current-buffer inferior-erlang-buffer
       (let ((msg nil))
 	(while (save-excursion
 		 (goto-char (process-mark inferior-erlang-process))
@@ -5331,8 +5477,7 @@ frame will become deselected before the next command."
 The empty command resembles hitting RET. This is useful in some
 situations, for instance if a crash or error report from sasl
 has been printed after the last prompt."
-  (save-excursion
-    (set-buffer inferior-erlang-buffer)
+  (with-current-buffer inferior-erlang-buffer
     (if (> (point-max) 1)
 	;; make sure we get a prompt if buffer contains data
 	(if (save-excursion
@@ -5398,7 +5543,7 @@ Return the position after the newly inserted command."
 	   (boundp 'comint-last-output-start))
       (save-excursion
 	(goto-char
-	 (if (interactive-p)
+	 (if (erlang-interactive-p)
 	     (symbol-value 'comint-last-input-end)
 	   (symbol-value 'comint-last-output-start)))
 	(while (progn (skip-chars-forward "^\C-h")
@@ -5417,7 +5562,7 @@ Return the position after the newly inserted command."
       (let ((pmark (process-mark (get-buffer-process (current-buffer)))))
 	(save-excursion
 	  (goto-char
-	   (if (interactive-p)
+	   (if (erlang-interactive-p)
 	       (symbol-value 'comint-last-input-end)
 	     (symbol-value 'comint-last-output-start)))
 	  (while (re-search-forward "\r+$" pmark t)
@@ -5444,23 +5589,21 @@ There exists two workarounds for this bug:
   (save-some-buffers)
   (inferior-erlang-prepare-for-input)
   (let* ((dir (inferior-erlang-compile-outdir))
-;;; (file (file-name-nondirectory (buffer-file-name)))
 	 (noext (substring (erlang-local-buffer-file-name) 0 -4))
 	 (opts (append (list (cons 'outdir dir))
 		       (if current-prefix-arg
 			   (list 'debug_info 'export_all))
 		       erlang-compile-extra-opts))
 	 end)
-    (save-excursion
-      (set-buffer inferior-erlang-buffer)
-      (compilation-forget-errors))
+    (with-current-buffer inferior-erlang-buffer
+      (when (fboundp 'compilation-forget-errors)
+        (compilation-forget-errors)))
     (setq end (inferior-erlang-send-command
 	       (inferior-erlang-compute-compile-command noext opts)
 	       nil))
     (sit-for 0)
     (inferior-erlang-wait-prompt)
-    (save-excursion
-      (set-buffer inferior-erlang-buffer)
+    (with-current-buffer inferior-erlang-buffer
       (setq compilation-error-list nil)
       (set-marker compilation-parsing-end end))
     (setq compilation-last-buffer inferior-erlang-buffer)))
@@ -5500,7 +5643,8 @@ unless the optional NO-DISPLAY is non-nil."
   (let ((ccfn erlang-compile-command-function-alist)
 	(res (inferior-erlang-compute-erl-compile-command module-name opts))
 	ccfn-entry
-	done)
+	done
+        result)
     (if (not (null (erlang-local-buffer-file-name)))
 	(while (and (not done) (not (null ccfn)))
 	  (setq ccfn-entry (car ccfn))
@@ -5630,12 +5774,14 @@ unless the optional NO-DISPLAY is non-nil."
        (tramp-tramp-file-p (buffer-file-name))))
 
 (defun erlang-tramp-get-localname ()
-  (let ((tramp-info (tramp-dissect-file-name (buffer-file-name))))
-    (if (fboundp 'tramp-file-name-localname)
-	(tramp-file-name-localname tramp-info)
-      ;; In old versions of tramp, it was `tramp-file-name-path'
-      ;; instead of the newer `tramp-file-name-localname'
-      (tramp-file-name-path tramp-info))))
+  (when (fboundp 'tramp-dissect-file-name)
+    (let ((tramp-info (tramp-dissect-file-name (buffer-file-name))))
+      (if (fboundp 'tramp-file-name-localname)
+          (tramp-file-name-localname tramp-info)
+        ;; In old versions of tramp, it was `tramp-file-name-path'
+        ;; instead of the newer `tramp-file-name-localname'
+        (when (fboundp 'tramp-file-name-path)
+          (tramp-file-name-path tramp-info))))))
 
 ;; `next-error' only accepts buffers with major mode `compilation-mode'
 ;; or with the minor mode `compilation-minor-mode' activated.
@@ -5652,16 +5798,14 @@ Capable of finding error messages in an inferior Erlang buffer."
 		 (and (boundp 'compilation-last-buffer)
 		      compilation-last-buffer))))
     (if (and (bufferp buf)
-	     (save-excursion
-	       (set-buffer buf)
+	     (with-current-buffer buf
 	       (and (eq major-mode 'erlang-shell-mode)
 		    (setq major-mode 'compilation-mode))))
 	(unwind-protect
 	    (progn
 	      (setq done t)
 	      (next-error argp))
-	  (save-excursion
-	    (set-buffer buf)
+	  (with-current-buffer buf
 	    (setq major-mode 'erlang-shell-mode))))
     (or done
 	(next-error argp))))
@@ -5764,7 +5908,7 @@ Simplified version of a combination `defalias' and `make-obsolete',
 it assumes that NEWDEF is loaded."
   (defalias sym (symbol-function newdef))
   (if (fboundp 'make-obsolete)
-      (make-obsolete sym newdef)))
+      (make-obsolete sym newdef "long ago")))
 
 
 (erlang-obsolete 'calculate-erlang-indent 'erlang-calculate-indent)
@@ -5782,11 +5926,8 @@ it assumes that NEWDEF is loaded."
 (erlang-obsolete 'name-of-erlang-function 'erlang-name-of-function)
 
 
-;; Fixme: shouldn't redefine `set-visited-file-name' anyhow -- see above.
 (defconst erlang-unload-hook
   (list (lambda ()
-	  (defalias 'set-visited-file-name
-	    'erlang-orig-set-visited-file-name)
 	  (when (featurep 'advice)
 	    (ad-unadvise 'Man-notify-when-ready)
 	    (ad-unadvise 'set-visited-file-name)))))