;; xref.el --- Cross referencing commands              -*-lexical-binding:t-*-

;; Copyright (C) 2014 Free Software Foundation, Inc.

;; Author: Helmut Eller <eller.helmut@gmail.com>

;; This work is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This work is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This file provides a somewhat generic infrastructure for cross
;; referencing commands, in particular "find-definition".  Some part of
;; the functionality must be implemented in a language dependent way
;; and that's done by defining a "backend".  The generic code finds
;; the backend by calling the function stored in the variable
;; `xref-backend-function'.  A language specific mode usually makes
;; `xref-backend-function' buffer local before storing into it.
;;
;; A backend is an instance of the EIEIO class xref-backend-class.
;; Various generic functions (in the EIEIO sense of the word) are
;; defined on xref-backend-class.  A language specific mode usually
;; creates a subclasses of xref-backend-class and provides specialized
;; methods for the generic functions.  See the `xref--elisp-backend'
;; and `etags--xref-backend' classes for examples.

(require 'cl-lib)
(require 'eieio)
(require 'ring)
(require 'find-func) ; for elisp backend

\f
;;; Locations

;; A location represents a position in a file or buffer.
(defclass xref-location () ())

;; If a backend decides to subclass xref-location it can provide
;; methods for some of the following functions:
(defgeneric xref-location-buffer (location))
(defgeneric xref-location-position (location))
(defgeneric xref-location= (location1 location2))
(defmethod xref-location= ((l1 xref-location) l2)
  (equal l1 l2))

;;;; Commonly needed location classes are defined here:

;; A file location is a file/line/colum triple.  Line numbers start
;; from 1 and columns from 0 (as inconstistent as the rest of Emacs).
;;
;; FIXME: might be useful to have an optional "hint" i.e. a string to
;; search for in case the line number is sightly out of date.
(defclass xref-file-location (xref-location)
  ((file :type string :initarg :file)
   (line :type fixnum :initarg :line)
   (column :type fixnum :initarg :column)))

(defun xref-make-file-location (file line column)
  (make-instance 'xref-file-location :file file :line line :column column))

(defmethod xref-location-buffer ((l xref-file-location))
  (with-slots (file) l
    (or (get-file-buffer file)
	(let ((find-file-suppress-same-file-warnings t))
	  (find-file-noselect file)))))

(defmethod xref-location-position ((l xref-file-location))
  (with-slots (line column) l
    (with-current-buffer (xref-location-buffer l)
      (save-restriction
	(widen)
	(save-excursion
	  (goto-char (point-min))
	  (beginning-of-line line)
	  (move-to-column column)
	  (point))))))

(defclass xref-buffer-location (xref-location)
  ((buffer :type buffer :initarg :buffer :reader xref-location-buffer)
   (position :type fixnum :initarg :position :reader xref-location-position)))

(defun xref-make-buffer-location (buffer position)
  (make-instance 'xref-buffer-location :buffer buffer :position position))

;; "Bogus" locations are sometimes useful to indicate errors,
;; e.g. when we know that a function exists but the actual location is
;; not known.
(defclass xref-bogus-location (xref-location)
  ((message :type string :initarg :message
	    :reader xref-bogus-location-message)))

(defun xref-make-bogus-location (message)
  (make-instance 'xref-bogus-location :message message))

(defmethod xref-location-buffer ((l xref-bogus-location))
  (with-slots (message) l
    (error "%s" message)))

(defmethod xref-location-position ((l xref-bogus-location))
  (with-slots (message) l
    (error "%s" message)))

\f
;;; cross reference

;; An xref is used to display and locate constructs like variables or
;; functions.
(defclass xref--xref ()
  ((description :type string :initarg :description
		:reader xref--xref-description)
   (location :type xref-location :initarg :location
	     :reader xref--xref-location)))

(defun xref-make (description location)
  (make-instance 'xref--xref :description description :location location))

\f
;;; Backend

;; Setting the variable `xref-backend-function' to a function that
;; returns a subclass of xref-backend-class can be used to provide
;; language specific behaviour, primarily `xref-lookup-definitions'.

;; Ugly name because defclass stores the class object in the symbol.
(defclass xref-backend-class () ())

;; For now, make the etags backend the default.
(defvar xref-backend-function 'etags-xref-backend-function)

(defun xref--backend ()
  (funcall xref-backend-function))

;;;; Backend interface functions

(defgeneric xref-lookup-definitions (backend identifier))
(defgeneric xref-lookup-references (backend identifier))

;; An identifier is backend specific.  By default it's a string but it
;; can be any type.  Well, nil means "no identifier at point" so that
;; can't be used.
(defgeneric xref-identifier-at-point (backend))
(defgeneric xref-read-identifier-from-minibuffer (backend prompt default))
(defgeneric xref-identifier-to-string (backend identifier))

;; default implementation for identifiers
(defmethod xref-identifier-at-point (_backend)
  (let ((thing (thing-at-point 'symbol)))
    (and thing (substring-no-properties thing))))

(defmethod xref-read-identifier-from-minibuffer (_backend prompt init)
  (read-from-minibuffer prompt init))

(defmethod xref-identifier-to-string (_backend identifier)
  (with-output-to-string (princ identifier)))

\f
;;; misc utilities
(defun xref--alistify (list key test)
  "Partition the elements of LIST into an alist.
KEY extracts the key from an element and TEST is used to compare
keys."
  (let ((alist '()))
    (dolist (e list)
      (let* ((k (funcall key e))
	     (probe (cl-assoc k alist :test test)))
	(if probe
	    (setcdr probe (cons e (cdr probe)))
          (push (cons k (list e)) alist))))
    ;; Put them back in order.
    (cl-loop for (key . value) in (reverse alist)
             collect (cons key (reverse value)))))

(defun xref--insert-propertized (props &rest strings)
  "Insert STRINGS with text properties PROPS."
  (let ((start (point)))
    (apply #'insert strings)
    (add-text-properties start (point) props)))

(defun xref--search-property (property &optional backward)
    "Search the next text range where text property PROPERTY is non-nil.
Return the value of PROPERTY.  If BACKWARD is non-nil, search
backward."
  (let ((next (if backward
		  #'previous-single-char-property-change
		#'next-single-char-property-change))
        (start (point))
        (value nil))
    (while (progn
             (goto-char (funcall next (point) property))
             (not (or (setq value (get-text-property (point) property))
                      (eobp)
                      (bobp)))))
    (cond (value)
	  (t (goto-char start) nil))))

\f
;;; Marker stack  (M-. pushes, M-, pops)

(defconst xref--marker-ring-length 16)

(defvar xref--marker-ring (make-ring xref--marker-ring-length)
  "Ring of markers to implement the marker stack.")

(defun xref-push-marker-stack ()
  "Add point to the marker stack."
  (ring-insert xref--marker-ring (point-marker)))

;;;###autoload
(defun xref-pop-marker-stack ()
  "Pop back to where \\[xref-find-definitions] was last invoked."
  (interactive)
  (let ((ring xref--marker-ring))
    (when (ring-empty-p ring)
      (error "Marker stack is empty"))
    (let ((marker (ring-remove ring 0)))
      (switch-to-buffer (or (marker-buffer marker)
			    (error "The marked buffer has been deleted")))
      (goto-char (marker-position marker))
      (set-marker marker nil nil))))

;; etags.el needs this
(defun xref-clear-marker-stack ()
  "Discard all markers from the marker stack."
  (let ((ring xref--marker-ring))
    (while (not (ring-empty-p ring))
      (let ((marker (ring-remove ring)))
	(set-marker marker nil nil)))))

\f
(defun xref--goto-location (location)
  "Set buffer and point according to xref-location LOCATION."
  (set-buffer (xref-location-buffer location))
  (let ((pos (xref-location-position location)))
    (cond ((and (<= (point-min) pos) (<= pos (point-max))))
	  (widen-automatically (widen))
	  (t (error "Location is outside accessible part of buffer")))
    (goto-char pos)))

(defun xref--pop-to-location (location &optional window)
  "Goto xref-location LOCATION and display the buffer.
WINDOW controls how the buffer is displayed:
  nil      -- switch-to-buffer
  'window  -- pop-to-buffer (other window)
  'frame   -- pop-to-buffer (other frame)"
  (xref--goto-location location)
  (cl-ecase window
    ((nil)  (switch-to-buffer (current-buffer)))
    (window (pop-to-buffer (current-buffer) t))
    (frame  (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))

\f
;;; XREF buffer (part of the UI)

;; The xref buffer is used to display a set of xrefs.

(defun xref--display-position (pos other-window recenter-arg)
  ;; show the location, but don't hijack focus.
  (with-selected-window (display-buffer (current-buffer) other-window)
    (goto-char pos)
    (recenter recenter-arg)))

(defgeneric xref--show-location (location))
(defmethod xref--show-location ((l xref-bogus-location))
  (with-slots (message) l
    (message "%s" message)))

(defmethod xref--show-location (location)
  (xref--goto-location location)
  (xref--display-position (point) t 1))

(defun xref--next-line (backward)
  (let ((loc (xref--search-property 'xref-location backward)))
    (when loc
      (xref--show-location loc))))

(defun xref-next-line ()
  "Move to the next xref and display its source in the other window."
  (interactive)
  (xref--next-line nil))

(defun xref-prev-line ()
  "Move to the previous xref and display its source in the other window."
  (interactive)
  (xref--next-line t))

(defun xref--location-at-point ()
  (or (get-text-property (point) 'xref-location)
      (error "No reference at point.")))

(defun xref-goto-xref ()
  "Jump to the xref at point and close the xref buffer."
  (interactive)
  (xref--show-location (xref--location-at-point))
  (quit-window))

(define-derived-mode xref--xref-buffer-mode fundamental-mode "XREF"
  "Mode for displaying cross refenences."
  (setq buffer-read-only t))

(let ((map xref--xref-buffer-mode-map))
  (define-key map (kbd "q") 'quit-window)
  (define-key map [remap next-line] 'xref-next-line)
  (define-key map [remap previous-line] 'xref-prev-line)
  (define-key map (kbd "RET") 'xref-goto-xref)

  ;; suggested by Johan Claesson "to further reduce finger movement":
  (define-key map (kbd ".") 'xref-next-line)
  (define-key map (kbd ",") 'xref-prev-line))

(defun xref--buffer-name () "*xref*")

(defun xref--insert-xrefs (xref-alist)
  "Insert XREF-ALIST in the current-buffer.
XREF-ALIST is of the form ((GROUP . (XREF ...)) ...).  Where
GROUP is a string for decoration purposes and XREF is an
`xref--xref' object."
  (cl-loop for ((group . xrefs) . more1) on xref-alist do
           (xref--insert-propertized '(face bold) group "\n")
           (cl-loop for (xref . more2) on xrefs do
		    (insert "  ")
		    (with-slots (description location) xref
		      (xref--insert-propertized
		       (list 'xref-location location
			     'face 'font-lock-keyword-face)
		       description))
		    (when (or more1 more2)
		      (insert "\n")))))

;; Return a string used to group a set of locations (this is typically
;; the filename).
(defgeneric xref-location-group (location))
(defmethod xref-location-group ((_ xref-bogus-location)) "(No location)")
(defmethod xref-location-group ((l xref-file-location))
  (with-slots (file) l
    file))
(defmethod xref-location-group ((l xref-buffer-location))
  (with-slots (buffer) l
    (or (buffer-file-name buffer)
	(format "(buffer %s)" (buffer-name buffer)))))

(defun xref--analyze (xrefs)
  "Find common filenames in XREFS.
Return an alist of the form ((FILENAME . (XREF ...)) ...)."
  (xref--alistify xrefs
		  (lambda (x)
		    (xref-location-group (xref--xref-location x)))
		  #'equal))

(defun xref--show-xref-buffer (xrefs)
  (let ((xref-alist (xref--analyze xrefs)))
    (with-current-buffer (get-buffer-create (xref--buffer-name))
      (let ((inhibit-read-only t))
	(erase-buffer)
	(xref--insert-xrefs xref-alist)
	(xref--xref-buffer-mode)
	(pop-to-buffer (current-buffer))
	(goto-char (point-min))
	(current-buffer)))))

\f
;; This part of the UI seems fairly uncontroversial: it reads the
;; identifier and deals with the single definition case.
;;
;; The controversial multiple definitions case is handed of to
;; xref-show-xrefs-function.

(defun xref--unique-location (xrefs)
  "If it exists, return the single location in the list XREFS.
If there are multiple or no locations in XREFS return nil."
  (and xrefs
       (let ((loc (xref--xref-location (car xrefs))))
	 (and (cl-every (lambda (x)
			  (xref-location= (xref--xref-location x) loc))
			(cdr xrefs))
	      loc))))

(defvar xref-show-xrefs-function 'xref--show-xref-buffer
  "Function to display a list of xrefs.")

(defun xref--show-xrefs (id kind xrefs window)
  (let ((1loc (xref--unique-location xrefs)))
    (cond ((null xrefs)
	   (error "No known %s for: %s"
		  kind (xref-identifier-to-string (xref--backend) id)))
	  (1loc
	   (xref-push-marker-stack)
	   (xref--pop-to-location 1loc window))
	  (t
	   (xref-push-marker-stack)
	   (funcall xref-show-xrefs-function xrefs)))))

(defun xref--read-identifier (prompt)
  "Return the identifier at point or read it from the minibuffer."
  (let* ((backend (xref--backend))
	 (id (xref-identifier-at-point backend)))
    (cond ((or current-prefix-arg (not id))
	   (let ((init (if id (xref-identifier-to-string backend id))))
	     (xref-read-identifier-from-minibuffer backend prompt init)))
	  (t id))))

\f
;;; Commands

(defun xref--find-definitions (id window)
  (xref--show-xrefs id "definitions"
		    (xref-lookup-definitions (xref--backend) id)
		    window))

;;;###autoload
(defun xref-find-definitions (identifier)
  "Find the definition of the identifier at point.
With prefix argument, prompt for the identifier."
  (interactive (list (xref--read-identifier "Find definitions of: ")))
  (xref--find-definitions identifier nil))

;;;###autoload
(defun xref-find-definitions-other-window (identifier)
  "Like `xref-find-definitions' but switch to the other window."
  (interactive (list (xref--read-identifier "Find definitions of: ")))
  (xref--find-definitions identifier 'window))

;;;###autoload
(defun xref-find-definitions-other-frame (identifier)
  "Like `xref-find-definitions' but switch to the other window."
  (interactive (list (xref--read-identifier "Find definitions of: ")))
  (xref--find-definitions identifier 'frame))

;;;###autoload
(defun xref-find-references (identifier)
  (interactive (list (xref--read-identifier "Find references of: ")))
  (xref--show-xrefs identifier "references"
		    (xref-lookup-references (xref--backend) identifier)
		    nil))

\f
;;; Key bindings

;;;###autoload (define-key esc-map "." 'xref-find-definitions)
;;;###autoload (define-key esc-map "," 'xref-pop-marker-stack)
;;;###autoload (define-key ctl-x-4-map "." 'xref-find-definitions-other-window)
;;;###autoload (define-key ctl-x-5-map "." 'xref-find-definitions-other-frame)

\f
;;; ELisp backend

;; This is defined here and not in elisp-mode.el so that we don't need
;; to load xref.el just to create the *scratch* buffer.

;; For now, this is just a wrapper around find-func.el in particular
;; `find-definition-noselect'.

(defclass xref--elisp-backend (xref-backend-class) ())

(defvar xref--elisp-backend-var (make-instance 'xref--elisp-backend))

;;;###autoload
(defun xref-elisp-backend-function () xref--elisp-backend-var)

(defun xref--elisp-find-definition (symbol type)
  (let ((loc (condition-case err
		 (let ((loc (save-excursion
			      (find-definition-noselect symbol type))))
		   (xref-make-buffer-location (car loc) (or (cdr loc) 1)))
	       (error
		(xref-make-bogus-location (error-message-string err)))))
	(desc (format "(%s %s)" (or type 'defun) symbol)))
    (xref-make desc loc)))

;; FIXME: include other stuff likes faces, compiler-macros, methods...
(defmethod xref-lookup-definitions ((_ xref--elisp-backend) id)
  (let ((sym (intern-soft id)))
    (if (null sym)
	'()
      (let ((fun (if (fboundp sym) (xref--elisp-find-definition sym nil)))
	    (var (if (boundp sym) (xref--elisp-find-definition sym 'defvar))))
	(remove nil (list fun var))))))

\f
(provide 'xref)

;;; xref.el ends here