go-guru.el

;;; go-guru.el --- Integration of the Go 'guru' analysis tool into Emacs.

;; Copyright 2016 The Go Authors. All rights reserved.
;; Use of this source code is governed by a BSD-style
;; license that can be found in the LICENSE file.

;; Version: 0.1
;; Package-Requires: ((go-mode "1.3.1") (cl-lib "0.5"))
;; Keywords: tools

;;; Commentary:

;; To enable the Go guru in Emacs, use this command to download,
;; build, and install the tool in $GOROOT/bin:
;;
;;     $ go get golang.org/x/tools/cmd/guru
;;
;; Verify that the tool is on your $PATH:
;;
;;     $ guru -help
;;     Go source code guru.
;;     Usage: guru [flags] <mode> <position>
;;     ...
;;
;; Then copy this file to a directory on your `load-path',
;; and add this to your ~/.emacs:
;;
;;     (require 'go-guru)
;;
;; Inside a buffer of Go source code, select an expression of
;; interest, and type `C-c C-o d' (for "describe") or run one of the
;; other go-guru-xxx commands.  If you use `menu-bar-mode', these
;; commands are available from the Guru menu.
;;
;; To enable identifier highlighting mode in a Go source buffer, use:
;;
;;     (go-guru-hl-identifier-mode)
;;
;; To enable it automatically in all Go source buffers,
;; add this to your ~/.emacs:
;;
;;     (add-hook 'go-mode-hook #'go-guru-hl-identifier-mode)
;;
;; See http://golang.org/s/using-guru for more information about guru.

;;; Code:

(require 'compile)
(require 'easymenu)
(require 'go-mode)
(require 'json)
(require 'simple)
(require 'cl-lib)

(defgroup go-guru nil
  "Options specific to the Go guru."
  :group 'go)

(defcustom go-guru-command "guru"
  "The Go guru command."
  :type 'string
  :group 'go-guru)

(defcustom go-guru-scope ""
  "The scope of the analysis.  See `go-guru-set-scope'."
  :type 'string
  :group 'go-guru)

(defvar go-guru--scope-history
  nil
  "History of values supplied to `go-guru-set-scope'.")

(defcustom go-guru-build-tags '()
  "Build tags passed to guru."
  :type '(repeat string)
  :group 'go-guru)

(defface go-guru-hl-identifier-face
  '((t (:inherit highlight)))
  "Face used for highlighting identifiers in `go-guru-hl-identifier'."
  :group 'go-guru)

(defcustom go-guru-debug nil
  "Print debug messages when running guru."
  :type 'boolean
  :group 'go-guru)

(defcustom go-guru-hl-identifier-idle-time 0.5
  "How long to wait after user input before highlighting the current identifier."
  :type 'float
  :group 'go-guru)

(defvar go-guru--current-hl-identifier-idle-time
  0
  "The current delay for hl-identifier-mode.")

(defvar go-guru--hl-identifier-timer
  nil
  "The global timer used for highlighting identifiers.")

(defvar go-guru--last-enclosing
  nil
  "The remaining enclosing regions of the previous go-expand-region invocation.")

;; Extend go-mode-map.
(let ((m (define-prefix-command 'go-guru-map)))
  (define-key m "d" #'go-guru-describe)
  (define-key m "f" #'go-guru-freevars)
  (define-key m "i" #'go-guru-implements)
  (define-key m "c" #'go-guru-peers)  ; c for channel
  (define-key m "r" #'go-guru-referrers)
  (define-key m "j" #'go-guru-definition) ; j for jump
  (define-key m "p" #'go-guru-pointsto)
  (define-key m "s" #'go-guru-callstack) ; s for stack
  (define-key m "e" #'go-guru-whicherrs) ; e for error
  (define-key m "<" #'go-guru-callers)
  (define-key m ">" #'go-guru-callees)
  (define-key m "x" #'go-guru-expand-region)) ;; x for expand

(define-key go-mode-map (kbd "C-c C-o") 'go-guru-map)

(easy-menu-define go-guru-mode-menu go-mode-map
  "Menu for Go Guru."
  '("Guru"
    ["Jump to Definition"    go-guru-definition t]
    ["Show Referrers"        go-guru-referrers t]
    ["Show Free Names"       go-guru-freevars t]
    ["Describe Expression"   go-guru-describe t]
    ["Show Implements"       go-guru-implements t]
    "---"
    ["Show Callers"          go-guru-callers t]
    ["Show Callees"          go-guru-callees t]
    ["Show Callstack"        go-guru-callstack t]
    "---"
    ["Show Points-To"        go-guru-pointsto t]
    ["Show Which Errors"     go-guru-whicherrs t]
    ["Show Channel Peers"    go-guru-peers t]
    "---"
    ["Set pointer analysis scope..." go-guru-set-scope t]))

(defun go-guru--read-scope ()
  "Read go-guru-scope from the minibuffer."
  (completing-read-multiple "guru-scope (comma-separated): "
                            (go-packages) nil nil nil 'go-guru--scope-history))

(eval-when-compile (require 'subr-x))

;;;###autoload
(defun go-guru-set-scope ()
  "Set the scope for the Go guru, prompting the user to edit the previous scope.

The scope restricts analysis to the specified packages.
Its value is a comma-separated list of patterns of these forms:
	golang.org/x/tools/cmd/guru     # a single package
	golang.org/x/tools/...          # all packages beneath dir
	...                             # the entire workspace.

A pattern preceded by '-' is negative, so the scope
	encoding/...,-encoding/xml
matches all encoding packages except encoding/xml."
  (interactive)
  (let ((scope (go-guru--read-scope)))
    (setq go-guru-scope (string-join scope ","))))

(defun go-guru--set-scope-if-empty ()
  (if (string-equal "" go-guru-scope)
      (go-guru-set-scope)))

(defun go-guru--json (mode)
  "Execute the Go guru in the specified MODE, passing it the
selected region of the current buffer, requesting JSON output.
Parse and return the resulting JSON object."
  ;; A "what" query works even in a buffer without a file name.
  (let* ((filename (file-truename (or buffer-file-name "synthetic.go")))
	 (cmd (go-guru--command mode filename '("-json")))
	 (buf (current-buffer))
	 ;; Use temporary buffers to avoid conflict with go-guru--start.
	 (json-buffer (generate-new-buffer "*go-guru-json-output*"))
	 (input-buffer (generate-new-buffer "*go-guru-json-input*")))
    (unwind-protect
	;; Run guru, feeding it the input buffer (modified files).
	(with-current-buffer input-buffer
	  (go-guru--insert-modified-files)
	  (unless (buffer-file-name buf)
	    (go-guru--insert-modified-file filename buf))
	  (let ((exitcode (apply #'call-process-region
				 (append (list (point-min)
					       (point-max)
					       (car cmd) ; guru
					       nil ; delete
					       json-buffer ; output
					       nil) ; display
					 (cdr cmd))))) ; args
	    (with-current-buffer json-buffer
	      (unless (zerop exitcode)
		;; Failed: use buffer contents (sans final \n) as an error.
		(error "%s" (buffer-substring (point-min) (1- (point-max)))))
	      ;; Success: parse JSON.
	      (goto-char (point-min))
	      (json-read))))
      ;; Clean up temporary buffers.
      (kill-buffer json-buffer)
      (kill-buffer input-buffer))))

(define-compilation-mode go-guru-output-mode "Go guru"
  "Go guru output mode is a variant of `compilation-mode' for the
output of the Go guru tool."
  (set (make-local-variable 'compilation-error-screen-columns) nil)
  (set (make-local-variable 'compilation-filter-hook) #'go-guru--compilation-filter-hook)
  (set (make-local-variable 'compilation-start-hook) #'go-guru--compilation-start-hook))

(defun go-guru--compilation-filter-hook ()
  "Post-process a blob of input to the go-guru-output buffer."
  ;; For readability, truncate each "file:line:col:" prefix to a fixed width.
  ;; If the prefix is longer than 20, show "…/last/19chars.go".
  ;; This usually includes the last segment of the package name.
  ;; Hide the line and column numbers.
  (let ((start compilation-filter-start)
	(end (point)))
    (goto-char start)
    (unless (bolp)
      ;; TODO(adonovan): not quite right: the filter may be called
      ;; with chunks of output containing incomplete lines.  Moving to
      ;; beginning-of-line may cause duplicate post-processing.
      (beginning-of-line))
    (setq start (point))
    (while (< start end)
      (let ((p (search-forward ": " end t)))
	(if (null p)
	    (setq start end) ; break out of loop
	  (setq p (1- p)) ; exclude final space
	  (let* ((posn (buffer-substring-no-properties start p))
		 (flen (cl-search ":" posn)) ; length of filename
		 (filename (if (< flen 19)
			       (substring posn 0 flen)
			     (concat "…" (substring posn (- flen 19) flen)))))
	    (put-text-property start p 'display filename)
	    (forward-line 1)
	    (setq start (point))))))))

(defun go-guru--compilation-start-hook (proc)
  "Erase default output header inserted by `compilation-mode'."
  (with-current-buffer (process-buffer proc)
    (let ((inhibit-read-only t))
      (goto-char (point-min))
      (delete-region (point) (point-max)))))

(defun go-guru--start (mode)
  "Start an asynchronous Go guru process for the specified query
MODE, passing it the selected region of the current buffer, and
feeding its standard input with the contents of all modified Go
buffers.  Its output is handled by `go-guru-output-mode', a
variant of `compilation-mode'."
  (or buffer-file-name
      (error "Cannot use guru on a buffer without a file name"))
  (let* ((filename (file-truename buffer-file-name))
	 (cmd (mapconcat #'shell-quote-argument (go-guru--command mode filename) " "))
	 (process-connection-type nil) ; use pipe (not pty) so EOF closes stdin
	 (procbuf (compilation-start cmd 'go-guru-output-mode)))
    (with-current-buffer procbuf
      (setq truncate-lines t)) ; the output is neater without line wrapping
    (with-current-buffer (get-buffer-create "*go-guru-input*")
      (erase-buffer)
      (go-guru--insert-modified-files)
      (process-send-region procbuf (point-min) (point-max))
      (process-send-eof procbuf))
    procbuf))

(defun go-guru--command (mode filename &optional flags)
  "Return a command and argument list for a Go guru query of MODE, passing it
the selected region of the current buffer.  FILENAME is the
effective name of the current buffer."
  (let* ((posn (if (use-region-p)
		   (format "%s:#%d,#%d"
			   filename
			   (1- (position-bytes (region-beginning)))
			   (1- (position-bytes (region-end))))
		 (format "%s:#%d"
			 filename
			 (1- (position-bytes (point))))))
	 (cmd (append (list go-guru-command
			    "-modified"
			    "-scope" go-guru-scope
			    (format "-tags=%s" (mapconcat 'identity go-guru-build-tags " ")))
		      flags
		      (list mode
			    posn))))
    ;; Log the command to *Messages*, for debugging.
    (when go-guru-debug
      (message "go-guru--command: %s" cmd)
      (message nil)) ; clear/shrink minibuffer
    cmd))

(defun go-guru--insert-modified-files ()
  "Insert the contents of each modified Go buffer into the
current buffer in the format specified by guru's -modified flag."
  (mapc #'(lambda (b)
	    (and (buffer-modified-p b)
		 (buffer-file-name b)
		 (string= (file-name-extension (buffer-file-name b)) "go")
		 (go-guru--insert-modified-file (buffer-file-name b) b)))
	(buffer-list)))

(defun go-guru--insert-modified-file (name buffer)
  (insert (format "%s\n%d\n" name (go-guru--buffer-size-bytes buffer)))
  (insert-buffer-substring buffer))

(defun go-guru--buffer-size-bytes (&optional buffer)
  "Return the number of bytes in the current buffer.
If BUFFER, return the number of characters in that buffer instead."
  (with-current-buffer (or buffer (current-buffer))
    (string-bytes (buffer-substring (point-min)
				    (point-max)))))

(defun go-guru--goto-byte (offset)
  "Go to the OFFSETth byte in the buffer."
  (goto-char (byte-to-position offset)))

(defun go-guru--goto-byte-column (offset)
  "Go to the OFFSETth byte in the current line."
  (goto-char (byte-to-position (+ (position-bytes (line-beginning-position)) (1- offset)))))

(defun go-guru--goto-pos (posn other-window)
  "Find the file containing the position POSN (of the form `file:line:col')
set the point to it, switching the current buffer."
  (let ((file-line-pos (split-string posn ":")))
    (funcall (if other-window #'find-file-other-window #'find-file) (car file-line-pos))
    (goto-char (point-min))
    (forward-line (1- (string-to-number (cadr file-line-pos))))
    (go-guru--goto-byte-column (string-to-number (cl-caddr file-line-pos)))))

(defun go-guru--goto-pos-no-file (posn)
  "Given `file:line:col', go to the line and column. The file
component will be ignored."
  (let ((file-line-pos (split-string posn ":")))
    (goto-char (point-min))
    (forward-line (1- (string-to-number (cadr file-line-pos))))
    (go-guru--goto-byte-column (string-to-number (cl-caddr file-line-pos)))))

;;;###autoload
(defun go-guru-callees ()
  "Show possible callees of the function call at the current point."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "callees"))

;;;###autoload
(defun go-guru-callers ()
  "Show the set of callers of the function containing the current point."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "callers"))

;;;###autoload
(defun go-guru-callstack ()
  "Show an arbitrary path from a root of the call graph to the
function containing the current point."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "callstack"))

;;;###autoload
(defun go-guru-definition (&optional other-window)
  "Jump to the definition of the selected identifier."
  (interactive)
  (or buffer-file-name
      (error "Cannot use guru on a buffer without a file name"))
  (let* ((res (go-guru--json "definition"))
	 (desc (cdr (assoc 'desc res))))
    (push-mark)
    (if (eval-when-compile (fboundp 'xref-push-marker-stack))
        ;; TODO: Integrate this facility with XRef.
        (xref-push-marker-stack)
      (ring-insert find-tag-marker-ring (point-marker)))
    (go-guru--goto-pos (cdr (assoc 'objpos res)) other-window)
    (message "%s" desc)))

;;;###autoload
(defun go-guru-definition-other-window ()
  "Jump to the defintion of the selected identifier in another window"
  (interactive)
  (go-guru-definition t))

;;;###autoload
(defun go-guru-describe ()
  "Describe the selected syntax, its kind, type and methods."
  (interactive)
  (go-guru--start "describe"))

;;;###autoload
(defun go-guru-pointsto ()
  "Show what the selected expression points to."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "pointsto"))

;;;###autoload
(defun go-guru-implements ()
  "Describe the 'implements' relation for types in the package
containing the current point."
  (interactive)
  (go-guru--start "implements"))

;;;###autoload
(defun go-guru-freevars ()
  "Enumerate the free variables of the current selection."
  (interactive)
  (go-guru--start "freevars"))

;;;###autoload
(defun go-guru-peers ()
  "Enumerate the set of possible corresponding sends/receives for
this channel receive/send operation."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "peers"))

;;;###autoload
(defun go-guru-referrers ()
  "Enumerate all references to the object denoted by the selected
identifier."
  (interactive)
  (go-guru--start "referrers"))

;;;###autoload
(defun go-guru-whicherrs ()
  "Show globals, constants and types to which the selected
expression (of type 'error') may refer."
  (interactive)
  (go-guru--set-scope-if-empty)
  (go-guru--start "whicherrs"))

(defun go-guru-what ()
  "Run a 'what' query and return the parsed JSON response as an
association list."
  (go-guru--json "what"))

(defun go-guru--hl-symbols (posn face id)
  "Highlight the symbols at the positions POSN by creating
overlays with face FACE. The attribute 'go-guru-overlay on the
overlays will be set to ID."
  (save-excursion
    (mapc (lambda (pos)
	    (go-guru--goto-pos-no-file pos)
	    (let ((x (make-overlay (point) (+ (point) (length (current-word))))))
	      (overlay-put x 'go-guru-overlay id)
	      (overlay-put x 'face face)))
	  posn)))

;;;###autoload
(defun go-guru-unhighlight-identifiers ()
  "Remove highlights from previously highlighted identifier."
  (remove-overlays nil nil 'go-guru-overlay 'sameid))

;;;###autoload
(defun go-guru-hl-identifier ()
  "Highlight all instances of the identifier under point. Removes
highlights from previously highlighted identifier."
  (interactive)
  (go-guru-unhighlight-identifiers)
  (go-guru--hl-identifier))

;;;###autoload
(define-minor-mode go-guru-hl-identifier-mode
  "Highlight instances of the identifier at point after a short
timeout."
  :group 'go-guru
  (if go-guru-hl-identifier-mode
      (progn
	(go-guru--hl-set-timer)
	;; Unhighlight if point moves off identifier
	(add-hook 'post-command-hook #'go-guru--hl-identifiers-post-command-hook nil t)
	;; Unhighlight any time the buffer changes
	(add-hook 'before-change-functions #'go-guru--hl-identifiers-before-change-function nil t))
    (remove-hook 'post-command-hook #'go-guru--hl-identifiers-post-command-hook t)
    (remove-hook 'before-change-functions #'go-guru--hl-identifiers-before-change-function t)
    (go-guru-unhighlight-identifiers)))

(defun go-guru--hl-identifier ()
  "Highlight all instances of the identifier under point."
  (let ((posn (cdr (assoc 'sameids (go-guru-what)))))
    (go-guru--hl-symbols posn 'go-guru-hl-identifier-face 'sameid)))

(defun go-guru--hl-identifiers-function ()
  "Function run after an idle timeout, highlighting the
identifier at point, if necessary."
  (when go-guru-hl-identifier-mode
    (unless (go-guru--on-overlay-p 'sameid)
      ;; Ignore guru errors. Otherwise, we might end up with an error
      ;; every time the timer runs, e.g. because of a malformed
      ;; buffer.
      (condition-case nil
	  (go-guru-hl-identifier)
	(error nil)))
    (unless (eq go-guru--current-hl-identifier-idle-time go-guru-hl-identifier-idle-time)
      (go-guru--hl-set-timer))))

(defun go-guru--hl-set-timer ()
  (if go-guru--hl-identifier-timer
      (cancel-timer go-guru--hl-identifier-timer))
  (setq go-guru--current-hl-identifier-idle-time go-guru-hl-identifier-idle-time)
  (setq go-guru--hl-identifier-timer (run-with-idle-timer
				      go-guru-hl-identifier-idle-time
				      t
				      #'go-guru--hl-identifiers-function)))

(defun go-guru--on-overlay-p (id)
  "Return whether point is on a guru overlay of type ID."
  (cl-find-if (lambda (el) (eq (overlay-get el 'go-guru-overlay) id)) (overlays-at (point))))

(defun go-guru--hl-identifiers-post-command-hook ()
  (if (and go-guru-hl-identifier-mode
	   (not (go-guru--on-overlay-p 'sameid)))
      (go-guru-unhighlight-identifiers)))

(defun go-guru--hl-identifiers-before-change-function (_beg _end)
  (go-guru-unhighlight-identifiers))

;; TODO(dominikh): a future feature may be to cycle through all uses
;; of an identifier.

(defun go-guru--enclosing ()
  "Return a list of enclosing regions."
  (cdr (assoc 'enclosing (go-guru-what))))

(defun go-guru--enclosing-unique ()
  "Return a list of enclosing regions, with duplicates removed.
Two regions are considered equal if they have the same start and
end point."
  (let ((enclosing (go-guru--enclosing)))
    (cl-remove-duplicates enclosing
			  :from-end t
			  :test (lambda (a b)
				  (and (= (cdr (assoc 'start a))
					  (cdr (assoc 'start b)))
				       (= (cdr (assoc 'end a))
					  (cdr (assoc 'end b))))))))

(defun go-guru-expand-region ()
  "Expand region to the next enclosing syntactic unit."
  (interactive)
  (let* ((enclosing (if (eq last-command #'go-guru-expand-region)
			go-guru--last-enclosing
		      (go-guru--enclosing-unique)))
	 (block (if (> (length enclosing) 0) (elt enclosing 0))))
    (when block
      (go-guru--goto-byte (1+ (cdr (assoc 'start block))))
      (set-mark (byte-to-position (1+ (cdr (assoc 'end block)))))
      (setq go-guru--last-enclosing (cl-subseq enclosing 1))
      (message "Region: %s" (cdr (assoc 'desc block)))
      (setq deactivate-mark nil))))


(provide 'go-guru)

;; Local Variables:
;; indent-tabs-mode: t
;; tab-width: 8
;; End:

;;; go-guru.el ends here