;;; deffy.el --- Show definitions in an Elisp project/buffer  -*- lexical-binding: t; -*-

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

;; Author: Adam Porter <adam@alphapapa.net>
;; Keywords: convenience, lisp
;; Package-Requires: ((emacs "27.2") (taxy "0.7"))

;; This program 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 program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; This library provides commands that show top-level forms and
;; definitions found in an Emacs Lisp project or buffer, organized by
;; file and type.

;;; Code:

(require 'map)
(require 'project)

(require 'taxy)
(require 'taxy-magit-section)

(cl-defstruct deffy-def
  ;; Okay, the name of this struct is silly, but at least it's concise.
  file pos form name type docstring)

(defgroup deffy nil
  "Show an overview of definitions in an Emacs Lisp project or buffer."
  :group 'emacs-lisp-mode)

;;;; Variables

(defvar deffy-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'deffy-RET)
    (define-key map [mouse-1] #'deffy-mouse-1)
    map))

(defvar-local deffy-directory nil
  "Directory relative to which filenames should be expanded.")

(defvar-local deffy-files nil
  "Files shown in the current Deffy buffer.")

(defvar-local deffy-display-buffer-action nil
  "Last-used display-buffer-action in the current Deffy buffer.")

;;;; Keys

(cl-eval-when (compile load eval)
  ;; I don't understand why using `cl-eval-when' is necessary, but it
  ;; seems to be.
  (taxy-define-key-definer deffy-define-key deffy-keys "deffy-key"
    ;; FIXME: Docstring.
    "")

  (deffy-define-key file ()
    (file-relative-name (deffy-def-file item) deffy-directory))

  (deffy-define-key type ()
    (pcase-let* (((cl-struct deffy-def form) item)
	         (type (pcase form
		         (`(,(or 'defun 'cl-defun) . ,_)
			  (if (cl-find-if (lambda (form)
					    (pcase form
					      (`(interactive . ,_) t)))
					  form)
			      'command
			    'function))
		         (`(,(or 'defmacro 'cl-defmacro) . ,_)
			  'macro)
		         (`(,car . ,_) car))))
      (when type
        (format "%s" type)))))

(defvar deffy-taxy-default-keys
  '(type file))

;;;; Columns

(cl-eval-when (compile load eval)
  ;; I don't understand why using `cl-eval-when' is necessary, but it
  ;; seems to be.
  (taxy-magit-section-define-column-definer "deffy"))

(deffy-define-column "Definition" (:max-width 45 :face font-lock-function-name-face)
  (format "%s" (deffy-def-name item)))

(deffy-define-column "Type" (:max-width 25 :face font-lock-type-face)
  (format "%s" (deffy-def-type item)))

(deffy-define-column "Docstring" (:max-width nil :face font-lock-doc-face)
  (deffy-def-docstring item))

(unless deffy-columns
  ;; TODO: Automate this or document it
  (setq-default deffy-columns
		(get 'deffy-columns 'standard-value)))

;;;; Options

(defcustom deffy-side-window-action
  '(display-buffer-in-side-window
    (side . right)
    (window-parameters
     (dedicated . t)
     (window-side . right)
     (no-delete-other-windows . t)))
  "`display-buffer' action used when displaying Deffy buffer in a side window.
See Info node `(elisp)Displaying Buffers in Side Windows'."
  :type 'sexp)

;;;; Commands

;;;###autoload
(cl-defun deffy
    (&key (project (or (project-current)
		       (cons 'transient default-directory)))
	  (keys deffy-taxy-default-keys)
	  (files deffy-files)
	  (buffer-name (format "*Deffy: %s*"
			       (if files
				   (string-join (mapcar #'file-relative-name files) ", ")
				 (file-name-nondirectory
				  (directory-file-name (project-root project))))))
	  visibility-fn display-buffer-action)
  "Show definitions defined in PROJECT or FILES.
Interactively, with PREFIX, show only definitions in current
buffer."
  (interactive (list :files (when current-prefix-arg
			      (list (buffer-file-name)))
		     :keys (if current-prefix-arg
			       (remove 'file deffy-taxy-default-keys)
			     deffy-taxy-default-keys)))
  (let (format-table column-sizes)
    (cl-labels (;; (heading-face
		;;  (depth) (list :inherit (list 'bufler-group (bufler-level-face depth))))
		(elisp-file-p (file) (string-match-p (rx ".el" (optional ".gz") eos) file))
		(file-visible-p
		 (file) (not (string-match-p (rx bos ".") (file-name-nondirectory file))))
		(format-item (item) (gethash item format-table))
		(make-fn (&rest args)
			 (apply #'make-taxy-magit-section
				:make #'make-fn
				:format-fn #'format-item
				:level-indent deffy-level-indent
				:visibility-fn visibility-fn
				;; :heading-face-fn #'heading-face
				args))
		(def-name (def) (format "%s" (cl-second (deffy-def-form def)))))
      ;; (when (get-buffer buffer-name)
      ;;   (kill-buffer buffer-name))
      (setf files (cl-reduce #'cl-remove-if-not (list #'file-exists-p #'elisp-file-p #'file-visible-p)
			     :initial-value (or files (project-files project))
			     :from-end t))
      (unless files
        (user-error "No files to show"))
      (with-current-buffer (get-buffer-create buffer-name)
	(deffy-mode)
	(setq-local deffy-taxy-default-keys keys
		    deffy-directory (project-root project)
		    deffy-files files
		    deffy-display-buffer-action display-buffer-action
		    default-directory deffy-directory)
	(let* ((forms (apply #'append (mapcar #'deffy--file-forms files)))
	       (taxy (thread-last
			 (make-fn
			  :name "Deffy"
			  :description
                          (format "Definitions in %s:"
				  (if files
				      (string-join (mapcar #'file-relative-name files) ", ")
				    (file-name-nondirectory
				     (directory-file-name (project-root project)))))
			  :take (taxy-make-take-function keys deffy-keys))
		       (taxy-fill forms)
		       (taxy-sort* #'string< #'taxy-name)
		       (taxy-sort #'string< #'def-name)))
	       (taxy-magit-section-insert-indent-items nil)
	       (inhibit-read-only t)
	       (format-cons (taxy-magit-section-format-items
			     deffy-columns deffy-column-formatters taxy)))
	  (setf format-table (car format-cons)
		column-sizes (cdr format-cons)
		header-line-format (taxy-magit-section-format-header
				    column-sizes deffy-column-formatters))
          (delete-all-overlays)
          (erase-buffer)
	  (save-excursion
	    (taxy-magit-section-insert taxy :items 'last
	      ;; :blank-between-depth bufler-taxy-blank-between-depth
	      :initial-depth 0))))
      (pop-to-buffer buffer-name display-buffer-action))))

;;;###autoload
(cl-defun deffy-buffer
    (&optional (buffer (current-buffer))
	       &key display-buffer-action)
  "Show an Deffy view for BUFFER.
Interactively, with prefix, display in dedicated side window."
  (interactive
   (list (current-buffer)
	 :display-buffer-action (when current-prefix-arg
				  deffy-side-window-action)))
  (unless (buffer-file-name buffer)
    (user-error "Buffer is not file-backed: %S.  See command `deffy-project'"
		buffer))
  (deffy :files (list (buffer-file-name buffer))
    :keys (remove 'file deffy-taxy-default-keys)
    :display-buffer-action display-buffer-action))

(cl-defun deffy-project (&optional project &key display-buffer-action)
  "Show an Deffy view for PROJECT.
Interactively, with prefix, display in dedicated side window."
  (interactive
   (list nil :display-buffer-action (when current-prefix-arg
				      deffy-side-window-action)))
  (deffy :project (or project
		      (project-current)
		      (cons 'transient default-directory))
    :display-buffer-action display-buffer-action))

(defun deffy-revert (_ignore-auto _noconfirm)
  "Revert current Deffy buffer."
  (interactive)
  (deffy :display-buffer-action (or deffy-display-buffer-action
				    '((display-buffer-same-window)))))

(defun deffy-jump (def)
  "Jump to definition DEF.
Interactively, read DEF from current buffer with completion; with
prefix, from all `deffy-mode' buffers."
  (interactive
   (list (deffy--read-def
	   (if current-prefix-arg
	       (cl-loop for buffer in (buffer-list)
			when (eq 'deffy-mode (buffer-local-value 'major-mode buffer))
			collect buffer)
	     (or (cl-loop for buffer in (buffer-list)
			  when (and (eq 'deffy-mode (buffer-local-value 'major-mode buffer))
				    (member (buffer-file-name)
                                            (buffer-local-value 'deffy-files buffer)))
			  return (list buffer))
		 (condition-case nil
		     (save-window-excursion
		       (deffy-buffer)
		       (list (current-buffer)))
		   (error (cl-loop for window in (window-list)
                                   when (eq 'deffy-mode
                                            (buffer-local-value 'major-mode (window-buffer window)))
                                   return (list (window-buffer window))))))))))
  (pcase-let (((cl-struct deffy-def file pos) def)
              (action (if (eq 'deffy-mode major-mode)
                          `(display-buffer-in-previous-window
                            (previous-window . ,(get-mru-window nil nil 'not-selected)))
                        '(display-buffer-same-window))))
    (pop-to-buffer
     (or (find-buffer-visiting file)
	 (find-file-noselect file))
     action)
    (goto-char pos)
    (backward-sexp 1)))

(defun deffy-mouse-1 (event)
  "Call `deffy-RET' with point at EVENT's position."
  (interactive "e")
  (mouse-set-point event)
  (call-interactively #'deffy-RET))

(defun deffy-RET ()
  "Go to form at point, or expand section at point."
  (interactive)
  (cl-etypecase (oref (magit-current-section) value)
    (deffy-def (deffy-jump (oref (magit-current-section) value)))
    (taxy-magit-section (call-interactively #'magit-section-cycle))
    (null nil)))

(define-derived-mode deffy-mode magit-section-mode "Deffy"
  :global nil
  (setq-local bookmark-make-record-function #'deffy-bookmark-make-record
	      revert-buffer-function #'deffy-revert))

;;;; Functions

(cl-defun deffy--read-def
    (deffy-buffers &key
      affixation-fn
      (annotate-fn (lambda (def)
		     (concat (deffy-def-type def) " " (deffy-def-docstring def))))
      (group-fn #'deffy-def-file))
  "Read form selected from Deffy BUFFERS with completion."
  (unless deffy-buffers
    (user-error "No Deffy buffers to find in"))
  (cl-labels ((def-cons
		(def) (cons (propertize
			     (format "%s" (deffy-def-name def))
			     :annotation (funcall annotate-fn def)
			     :group (funcall group-fn def)
			     :def def)
			    def))
	      (buffer-taxy
	       (buffer) (with-current-buffer buffer
			  (save-excursion
			    (goto-char (point-min))
			    (oref (magit-current-section) value))))
	      (annotate
	       (candidate)
	       (concat (propertize " " 'display '(space :align-to center))
		       (get-text-property 0 :annotation candidate)))
	      (group
	       (candidate transform)
	       (pcase transform
		 (`nil (get-text-property 0 :group candidate))
		 (_ candidate)))
	      (affix (candidates)
		     (cl-loop for candidate in candidates collect
		              (list (propertize candidate
					        'face 'font-lock-function-name-face)
			            (concat (propertize
                                             (symbol-name
                                              (deffy-def-type
					        (get-text-property 0 :def candidate)))
					     'face 'font-lock-type-face)
				            "  ")
			            (concat (propertize " "
                                                        'display '(space :align-to center))
				            (get-text-property 0 :annotation candidate))))))
    (pcase (length deffy-buffers)
      (1 (setf annotate-fn #'deffy-def-docstring
	       group-fn #'deffy-key-type))
      (_ (setf annotate-fn #'deffy-def-docstring
               affixation-fn #'affix)))
    (let* ((taxys (mapcar #'buffer-taxy deffy-buffers))
	   (items (mapcan #'taxy-flatten taxys))
	   (alist (setf items (mapcar #'def-cons items)))
	   (metadata (list 'metadata (cons 'group-function #'group)))
	   (dynamic-fn (lambda (str pred flag)
			 (pcase flag
			   ('metadata metadata)
			   (_ (complete-with-action flag alist str pred)))))
	   (completion-extra-properties (list :annotation-function #'annotate
					      :affixation-function affixation-fn))
	   (selected (completing-read "Definition: " dynamic-fn nil t)))
      (alist-get selected alist nil nil #'equal))))

(cl-defun deffy--file-forms (file)
  "Return forms defined in FILE."
  (with-temp-buffer
    (save-excursion
      (insert-file-contents file))
    (cl-loop for form = (ignore-errors
			  (read (current-buffer)))
	     while form
	     when (listp form)
	     collect (make-deffy-def
                      :file file :pos (point) :form form
                      :name (pcase-exhaustive (cadr form)
			      ((and (pred atom) it) it)
			      (`(quote ,it) it)
			      (`(,it . ,_) it))
                      :type (car form)
                      :docstring
                      (replace-regexp-in-string
                       "\n" "  "
                       (pcase form
		         (`(,(or 'defun 'cl-defun 'defmacro 'cl-defmacro) ,_name ,_args
		            ,(and (pred stringp) docstring) . ,_)
		          docstring)
		         (`(,(or 'defvar 'defvar-local 'defcustom) ,_name ,_value
		            ,(and (pred stringp) docstring) . ,_)
		          docstring)
		         (_ ;; Use the first string found, if any.
		          (or (cl-find-if #'stringp form)
                              ""))))))))

;;;;; Bookmark support

(defvar bookmark-make-record-function)

(defun deffy-bookmark-make-record ()
  "Return a bookmark record for current Deffy buffer."
  (list (concat "Deffy: %s" deffy-directory)
	(cons 'directory deffy-directory)
	(cons 'files deffy-files)
	(cons 'handler #'deffy-bookmark-handler)))

;;;###autoload
(defun deffy-bookmark-handler (record)
  "Show Deffy buffer for bookmark RECORD."
  (pcase-let* ((`(,_ . ,(map directory files)) record))
    (deffy :files files :project (project-current nil directory))
    (current-buffer)))

(provide 'deffy)

;;; deffy.el ends here
