blob: 4b58bfc8391fd6b6bce4e91a161f5a666bf86ed6 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
;;; 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
|