dotfiles/.emacs.d/contrib/git-related.el

;;; git-related.el --- Find related files through commit history analysis -*- lexical-binding: t -*-

;; Copyright (C) 2023 Nthcdr

;; Author: Nthcdr <nthcdr@macroexpand.net>
;; Maintainer: Nthcdr <nthcdr@macroexpand.net>
;; URL: https://macroexpand.net/el/git-related.el
;; Version: 1.0
;; Package-Requires: ((emacs "28.1"))

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Find files by recommendation based on git commit history.

;; Usage: Visiting a git versioned file run once (and then only when
;; you feel the need to refresh) `git-related-update` than you will get
;; suggestions based on the current file through invocations to
;; `git-related-find-file`

;;; Code:

(require 'cl-lib)
(require 'subr-x)
(require 'project)
(require 'vc-git)

(defface git-related-score
 '((t (:foreground "#f1fa8c")))
 "Face used for git related score."
 :group 'git-related)

(defface git-related-file
  '((t (:foreground "#ff79c6")))
  "Face used for git related file name."
  :group 'git-related)

(defvar git-related--graphs nil)

(cl-defstruct git-related--graph files commits)
(cl-defstruct git-related--file (name "" :type string) (commits nil :type list))
(cl-defstruct git-related--commit (sha "" :type string) (files nil :type list))

(defun git-related--new-graph ()
 "Create an empty graph."
 (make-git-related--graph
  :files (make-hash-table :test 'equal :size 2500)
  :commits (make-hash-table :test 'equal :size 2500)))

(defun git-related--record-commit (graph sha filenames)
 "Record in the GRAPH the relation between SHA and FILENAMES."
 (let ((commit (make-git-related--commit :sha sha)))
  (dolist (filename filenames)
   (let* ((seen-file (gethash filename (git-related--graph-files graph)))
          (file-found (not (null seen-file)))
          (file (or seen-file (make-git-related--file :name filename))))

    (cl-pushnew commit (git-related--file-commits file))
    (cl-pushnew file (git-related--commit-files commit))

    (unless file-found
     (setf (gethash filename (git-related--graph-files graph)) file))))

  (setf (gethash sha (git-related--graph-commits graph)) commit)))

(defun git-related--replay (&optional graph)
 "Replay git commit history into optional GRAPH."
 (let ((graph (or graph (git-related--new-graph))))
  (with-temp-buffer
   (process-file vc-git-program nil t nil "log" "--name-only" "--format=%x00%H")
   (let* ((commits (split-string (buffer-string) "\0" t))
          (replay-count 0)
          (progress-reporter (make-progress-reporter "Building commit-file graph..." 0 (length commits))))
    (dolist (commit commits)
     (let* ((sha-and-paths (split-string commit "\n\n" t (rx whitespace)))
            (sha (car sha-and-paths))
            (paths (when (cadr sha-and-paths)
                    (split-string (cadr sha-and-paths) "\n" t (rx whitespace)))))
      (git-related--record-commit graph sha paths)
      (progress-reporter-update progress-reporter (cl-incf replay-count))))
    (progress-reporter-done progress-reporter)))
  graph))

(defun git-related--similar-files (graph filename)
 "Return files in GRAPH that are similar to FILENAME."
 (unless (git-related--graph-p graph)
  (user-error "You need to index this project first"))
 (let ((file (gethash filename (git-related--graph-files graph))))
  (when file
   (let ((file-sqrt (sqrt (length (git-related--file-commits file))))
         (neighbor-sqrts (make-hash-table :test 'equal :size 100))
         (hits (make-hash-table :test 'equal :size 100)))

    (dolist (commit (git-related--file-commits file))
     (dolist (neighbor (remove file (git-related--commit-files commit)))
      (let ((count (cl-incf (gethash (git-related--file-name neighbor) hits 0))))
       (when (= count 1)
        (setf (gethash (git-related--file-name neighbor) neighbor-sqrts)
         (sqrt (length (git-related--file-commits neighbor))))))))

    (let (ranked-neighbors)
     (maphash
      (lambda (neighbor-name neighbor-sqrt)
       (let ((axb (* file-sqrt neighbor-sqrt))
             (n (gethash neighbor-name hits)))
        (push (list (if (cl-plusp axb) (/ n axb) 0.0) neighbor-name) ranked-neighbors)))
      neighbor-sqrts)
     (cl-sort
      (cl-remove-if-not #'git-related--file-exists-p ranked-neighbors :key #'cadr)
      #'> :key #'car))))))

(defun git-related--file-exists-p (relative-filename)
 "Determine if RELATIVE-FILENAME currently exists."
 (file-exists-p
  (expand-file-name relative-filename
   (project-root (project-current)))))

(defun git-related--propertize (hit)
 "Given the cons HIT return a rendered representation for completion."
 (propertize
  (concat
   (propertize (format "%2.2f" (car hit)) 'face 'git-related-score)
   " ---> "
   (propertize (cadr hit) 'face 'git-related-file))
  'path (cadr hit)))

;;;###autoload
(defun git-related-update ()
 "Update graph for the current project."
 (interactive)
 (let* ((default-directory (project-root (project-current)))
	(project-symbol (intern (project-name (project-current))))
	(graph (cl-getf git-related--graphs project-symbol)))
  (setf (cl-getf git-related--graphs project-symbol)
   (git-related--replay graph))))

;;;###autoload
(defun git-related-find-file ()
 "Find files related through commit history."
 (interactive)
 (if (buffer-file-name)
  (let ((default-directory (project-root (project-current))))
   (find-file
    (let* ((selection
	    (completing-read "Related files: "
	     (mapcar #'git-related--propertize
	      (git-related--similar-files
	       (cl-getf git-related--graphs (intern (project-name (project-current))))
	       (file-relative-name (buffer-file-name) (project-root (project-current)))))
	     nil t)))
     (when selection
      (let ((filename (get-text-property 0 'path selection)))
       (find-file filename))))))
  (message "Current buffer has no file")))

(provide 'git-related)

;;; git-related.el ends here