-
Notifications
You must be signed in to change notification settings - Fork 2
/
tmsu-dired-overlay.el
160 lines (132 loc) · 6.1 KB
/
tmsu-dired-overlay.el
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
;;; tmsu-dired-overlay.el --- Dired overlays with TMSU tags -*- lexical-binding: t; -*-
;; Copyright (C) 2022-2023 Wojciech Siewierski
;; Author: Wojciech Siewierski
;; URL: https://github.com/vifon/tmsu.el
;; Keywords: files
;; Version: 0.9
;; 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:
;; Dired overlays with TMSU tags.
;;; Code:
(require 'tmsu-dired)
(defgroup tmsu-dired-overlay nil
"Dired overlays with TMSU tags."
:group 'tmsu-dired)
(defface tmsu-dired-overlay-face
'((t (:inherit italic)))
"The face used for the tags in the overlays.")
(defvar-local tmsu-dired-overlay-overlays nil)
(defun tmsu-dired-overlay-delete-all-overlays (&rest _)
"Delete all overlays in `tmsu-dired-overlay-overlays'.
Intended as an advice for `revert-buffer-function', removes
itself from this variable's value."
(interactive)
(mapc #'delete-overlay tmsu-dired-overlay-overlays)
(kill-local-variable 'tmsu-dired-overlay-overlays)
(remove-function (local 'revert-buffer-function)
#'tmsu-dired-overlay-delete-all-overlays))
(defun tmsu-dired-overlay-delete-overlays (&optional beg end)
"Delete `tmsu-dired-overlay-overlays' between positions BEG and END.
BEG and END default to `dired-subdir-min' and
`dired-subdir-max' respectively."
(interactive)
(setq beg (or beg (dired-subdir-min))
end (or end (dired-subdir-max)))
(dolist (ov (overlays-in beg end))
(when (memq ov tmsu-dired-overlay-overlays)
(setq tmsu-dired-overlay-overlays
(delq ov tmsu-dired-overlay-overlays))
(delete-overlay ov))))
(defun tmsu-dired-overlay-follow-link (button)
"Follow the BUTTON and call `tmsu-dired-query' accordingly."
;; This `default-directory' could have been a call to
;; `dired-current-directory' for slightly different semantics.
;; This choice is deliberate and not a bug, as I find these
;; semantics reasonable.
(tmsu-dired-query default-directory
(cons (button-get button 'tmsu-tag) tmsu-dired-query-args)
tmsu-dired-query-flags))
(define-button-type 'tmsu-dired-overlay-button
'follow-link t
'action #'tmsu-dired-overlay-follow-link
'help-echo "mouse-2: narrow down the TMSU query"
'face 'tmsu-dired-overlay-face)
(defun tmsu-dired-overlay-create-overlay-at-point (tags &optional file-tags)
"Add an overlay with TAGS values on the current `dired' line.
The pre-computed tags for the current file can be passed with
FILE-TAGS. This way no additional TMSU queries are performed.
FILE-TAGS should be a cons cell with the filename in its `car'
and the tag list in its `cdr'. In such case it's expected for
FILE-TAGS to already be pre-filtered and the value of TAGS
is ignored."
(when-let ((values (if file-tags
(cdr file-tags)
(tmsu-get-tags (dired-get-filename nil t) tags))))
(end-of-line)
(let ((ov (make-overlay (point) (point) nil t nil)))
(overlay-put ov 'after-string
(with-temp-buffer
(insert
;; Display the cursor before the overlay, not after.
(propertize " " 'cursor t)
;; Crudely align the tag lists using tab-stops.
;; Won't be pretty, but won't be terrible
;; either. Should always provide at least two
;; characters of spacing.
"\t")
(dolist (tag values)
(insert-text-button tag
:type 'tmsu-dired-overlay-button
'tmsu-tag tag)
(insert ","))
;; Remove the "," after the last tag. Would be
;; buggy for an empty list, but this scenario
;; will never happen due to the check at the
;; beginning of this function.
(delete-char -1)
(buffer-string)))
(push ov tmsu-dired-overlay-overlays))))
(defun tmsu-dired-overlay-create-overlays (&optional tags)
"Add overlays with the values of TAGS to all `dired' files.
If TAGS is nil, show all the tags with no filtering."
(save-excursion
(goto-char (dired-subdir-min))
(let ((max (1- (dired-subdir-max)))
(file-tags-alist (tmsu-get-tags-for-files
(directory-files (dired-current-directory) t)
tags)))
(while (< (point) max)
(when-let ((file (dired-get-filename nil t)))
(tmsu-dired-overlay-create-overlay-at-point
tags (assoc file file-tags-alist)))
(forward-line 1))))
(add-function :before (local 'revert-buffer-function)
#'tmsu-dired-overlay-delete-all-overlays))
;;;###autoload
(defun tmsu-dired-overlay (&optional only-remove)
"Interactively add/replace overlays with tag values to `dired'.
When ONLY-REMOVE (\\[universal-argument]) is passed, don't ask
for tags and only remove the tag overlays within the current
subdir instead.
Selecting an empty list of tags displays all the tags."
(interactive "P")
(unless (tmsu-database-p)
(error "No TMSU database"))
(if only-remove
(tmsu-dired-overlay-delete-overlays)
(let ((tags (completing-read-multiple
"TMSU tags to display: " (tmsu-get-tags)
nil nil nil 'tmsu-query-history)))
(tmsu-dired-overlay-delete-overlays)
(tmsu-dired-overlay-create-overlays tags))))
(provide 'tmsu-dired-overlay)
;;; tmsu-dired-overlay.el ends here