-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathcursorless-hats.el
170 lines (147 loc) · 7.08 KB
/
cursorless-hats.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
161
162
163
164
165
166
167
168
169
170
;;; cursorless-hats.el --- Description -*- lexical-binding: t; -*-
;;; Commentary:
;; The code for managing hat decorations.
;;
;;; Code:
(require 'json)
;; READING & DRAWING HATS FROM CURSORLESS
(defconst cursorless-hats-file
(concat cursorless-directory "vscode-hats.json"))
(defcustom cursorless-color-alist
'((default . "#999")
(blue . "#04f")
(red . "#e00")
(pink . "#ffa0ff")
(green . "#0b0")
(yellow . "ffc000")
(userColor1 . "#6a00ff")
(userColor2 . "#ffd8b1"))
"The mapping from cursorless color phrases to emacs colors."
:type '(alist :key-type symbol :value-type string)
:group 'cursorless)
(defvar cursorless-show-hats t)
(defvar cursorless-updating-hats nil)
(defvar cursorless-hats-update-timer nil)
(defun cursorless-hats-update-callback (&optional event)
(unless cursorless-running-command
;; recursive invocations can occur if running cursorless-update-hats causes
;; the hats file to change; eg. if cursorless-update-hats writes to *Messages*
;; and we're visiting *Messages*. Without care this can lock up emacs.
(if cursorless-updating-hats
(progn
(cursorless-log "cursorless-hats-update-callback: recursive invocation detected!")
(warn "cursorless-hats-update-callback: recursive invocation detected!"))
;; the hats file could be stale which would make finding the right cursor positions fail
;; with an end-of-buffer error. ignore these errors since they're normally remediated
;; very quickly.
(if (not (ignore-error end-of-buffer
(setq cursorless-updating-hats t)
(when cursorless-show-hats
(let ((hats-json (cursorless-read-hats-json)))
(seq-each (lambda (file-hats)
(let* ((file (car file-hats))
(hats (cdr file-hats))
(file (symbol-name file))
(related-buffer (gethash file cursorless-temporary-file-buffers)))
(if (not related-buffer)
(message "temporary file not associated with a buffer: %S" file)
(cursorless-update-hats related-buffer hats)))) hats-json)))
t))
(cursorless-log "failed to update hats (end-of-buffer aka stale hats file)"))
(setq cursorless-updating-hats nil))))
(defun cursorless-hats-change-callback (event)
(when (and (equal (nth 1 event) 'changed)
(string-equal (nth 2 event) (expand-file-name cursorless-hats-file)))
(when cursorless-updating-hats
(cursorless-log (format "cursorless-hats CHANGE RECURSIVE, set cursorless-updating-hats to nil to re-enable\n%s" (backtrace-to-string)))
(message "cursorless-hats CHANGE RECURSIVE, set cursorless-updating-hats to nil to re-enable"))
(unless cursorless-updating-hats
(cursorless-hats-update-callback))))
(defvar cursorless-hats-watcher
(progn
(when (and (boundp 'cursorless-hats-watcher) cursorless-hats-watcher)
(file-notify-rm-watch cursorless-hats-watcher))
;; We have to watch the whole directory for changes otherwise we can't get notifications about
;; the hats file being created on macOS.
(file-notify-add-watch cursorless-directory '(change) 'cursorless-hats-change-callback)))
;; FIXME: need to initialize hats whenever we switch to a buffer without them.
(defun cursorless-show-hats ()
(interactive)
(when cursorless-show-hats (cursorless-clear-overlays))
(setq cursorless-show-hats t)
(cursorless-hats-update-callback))
(defun cursorless-hide-hats ()
(interactive)
;; TODO: filter buffer-list by a cursorless-mode marker
(seq-each (lambda (buffer)
(with-current-buffer buffer
(cursorless-clear-overlays))) (buffer-list))
(setq cursorless-show-hats nil))
(defun cursorless-clear-overlays ()
(interactive)
(remove-overlays nil nil 'cursorless t))
(defun cursorless-read-hats-json ()
"Read the hats file and return an alist.
Hats are stored as a JSON object like:
{
FILEPATH: {
COLORNAME: [ { \"start\": { \"line\": l, \"character\": c },
\"end\": { \"line\": l, \"character\": c } },
... more hat positions ... ]
... more colors ...
},
... more files ...
}
COLORNAME is sometimes a color name e.g. blue and sometimes a color followed
by a shape e.g. blue-bolt."
(with-temp-buffer
(insert-file-contents-literally cursorless-hats-file)
(json-parse-buffer :object-type 'alist)))
(defun cursorless-update-hats (buffer hats)
"Update BUFFER with HATS."
(with-current-buffer buffer
(cursorless-log (format "updating hats on %S" buffer))
(cursorless-clear-overlays)
(seq-map (lambda(color-shape-positions)
(let* ((color-shape (string-split (symbol-name (car color-shape-positions)) "-"))
(color (car color-shape))
(shape (cadr color-shape))
(draw-hat (apply-partially 'cursorless-draw-hat (intern color) shape)))
(seq-map draw-hat (cdr color-shape-positions)))) hats)
(cursorless-log (format "done updating hats on %S" buffer))))
(defun cursorless-point-from-cursorless-position (cursorless-position)
"Return the proper point for an alist from a cursorless position.
CURSORLESS-POSITION is an alist parsed from `cursorless-read-hats-json'."
(let ((pos (alist-get 'start cursorless-position)))
(save-excursion
(goto-char (point-min))
;; consider using https://emacs.stackexchange.com/a/3822. this offers roughly a 10x speedup.
(forward-line (alist-get 'line pos))
(forward-char (alist-get 'character pos))
(point))))
(defun cursorless--get-hat-color (cursorless-color)
(if-let ((hat-color (alist-get cursorless-color cursorless-color-alist)))
hat-color
(display-warning 'cursorless
(format "Unable to find mapping for cursorless color %s."
cursorless-color) :error)))
(defun cursorless-draw-hat (cursorless-color cursorless-shape cursorless-position)
"Draw an individual hat on the current buffer.
CURSORLESS-COLOR is a color name (e.g. default, blue, pink) that gets translated
through `cursorless-color-alist'.
CURSORLESS-SHAPE is the shape to render. If CURSORLESS-SHAPE is nil, the default
dot gets rendered.
CURSORLESS-POSITION is an alist parsed from `cursorless-read-hats-json'."
(when-let* ((hat-color (cursorless--get-hat-color cursorless-color))
(hat-point (cursorless-point-from-cursorless-position cursorless-position))
(hat-overlay (make-overlay hat-point (+ hat-point 1))))
(overlay-put hat-overlay 'cursorless t)
(cond ((null cursorless-shape)
(overlay-put hat-overlay 'face `(:cursorless ,hat-color)))
((string-equal cursorless-shape "frame")
(overlay-put hat-overlay 'face `(:box (:line-width (0 . -2) :color ,hat-color))))
(t (display-warning
'cursorless
(format "Unable to find mapping for cursorless shape %s." cursorless-shape) :error)))))
(provide 'cursorless-hats)
;;; cursorless-hats.el ends here