-
Notifications
You must be signed in to change notification settings - Fork 0
/
bookmark.lisp
285 lines (240 loc) · 11.5 KB
/
bookmark.lisp
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
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
;;;; -*- mode: lisp; coding: utf-8 -*-
;;;; Bookmark package for lem
;;;;
(defpackage :bookmark
(:use :cl :lem)
(:export
;; customization variables
:*file*
:*keymap*
;; bookmark type
:bookmark
:bookmark-name
:bookmark-filename
:bookmark-position
:bookmark-p
;; internal functions for commands
:load-from-file
:save-to-file
;; commands
:bookmark-load
:bookmark-save
:bookmark-set
:bookmark-set-no-position
:bookmark-set-no-overwrite
:bookmark-set-no-position-no-overwrite
:bookmark-delete
:bookmark-delete-all
:bookmark-rename
:bookmark-relocate
:bookmark-jump))
(in-package :bookmark)
(setf (documentation *package* t)
"Bookmarks for the lem editor.
Bookmarks are paths to files or directories that make it easy to open them. Each
bookmark has a name, and can have a position assotiated with it.
The command BOOKMARK-SET is used to create a new bookmark, which points to the file
of the current buffer and the current cursor position. The name of the bookmark will be
prompted for. If you wish to not associate a position with the bookmark, you can use
BOOKMARK-SET-NO-POSITION. This might be useful, if another package is managing file
positions for you.
To open a previously set bookmark, use BOOKMARK-JUMP.
The set bookmarks are not persisted automatically. The commands BOOKMARK-SAVE and
BOOKMARK-LOAD are used to save and load the bookmarks from disk. The variable
*FILE* configures from which file the bookmark information is read from/saved to.
The keymap *KEYMAP* has some pre-defined mappings for most of the available commands.
Use (DESCRIBE (FIND-PACKAGE \"BOOKMARK\")) to find all available commands.")
(defvar *file* #P"bookmarks.lisp-expr"
"File in which bookmarks are saved.
If the file is a relative path, it is relative to LEM-HOME.")
(defvar *keymap*
(make-keymap :name "Bookmark keymap")
"Keymap for bookmark related commands.")
(defvar *bookmark-table* (make-hash-table :test #'equal))
(define-key *keymap* "x" 'bookmark-set)
(define-key *keymap* "X" 'bookmark-set-no-overwrite)
(define-key *keymap* "m" 'bookmark-set)
(define-key *keymap* "M" 'bookmark-set-no-overwrite)
(define-key *keymap* "j" 'bookmark-jump)
(define-key *keymap* "g" 'bookmark-jump)
(define-key *keymap* "l" 'bookmark-load)
(define-key *keymap* "s" 'bookmark-save)
(define-key *keymap* "d" 'bookmark-delete)
(define-key *keymap* "D" 'bookmark-delete-all)
(define-key *keymap* "r" 'bookmark-rename)
(define-key *keymap* "R" 'bookmark-rename-no-overwrite)
(define-key *keymap* "h" 'bookmark-relocate)
(defstruct bookmark
(name)
(filename)
(position))
(defun bookmark-deserialize (list)
(let* ((bookmark-name (car list))
(bookmark-data (cdr list))
(entry (make-bookmark
:name bookmark-name
:filename (cdr (assoc :filename bookmark-data))
:position (cdr (assoc :position bookmark-data)))))
entry))
(defun bookmark-serialize (entry)
(remove-if (lambda (field) (and (consp field) (null (cdr field))))
(list (bookmark-name entry)
(cons :filename (bookmark-filename entry))
(cons :position (bookmark-position entry)))))
(defun %bookmark-insert (name buffer &key no-position)
(let ((path (cond ((buffer-filename buffer)
(buffer-filename buffer))
((string= "Directory" (mode-name (buffer-major-mode buffer)))
(buffer-directory buffer)))))
(when path
(setf (gethash name *bookmark-table*)
(make-bookmark :name name
:filename path
:position (if no-position
nil
(position-at-point (buffer-point buffer)))))
t)))
(defun %bookmark-find (name)
(gethash name *bookmark-table*))
(defun %bookmark-delete (entry)
(remhash (bookmark-name entry) *bookmark-table*))
(defun %bookmark-update (entry &key (new-name nil new-name-p)
(new-filename nil new-filename-p)
(position nil new-position-p))
(when new-name-p
(remhash (bookmark-name entry) *bookmark-table*)
(setf (bookmark-name entry) new-name)
(setf (gethash new-name *bookmark-table*) entry))
(when new-filename-p
(setf (bookmark-filename entry) new-filename))
(when new-position-p
(setf (bookmark-position entry) new-position)))
(defun %bookmark-relocate (entry buffer &key no-position)
(%bookmark-update
entry
:new-filename (buffer-filename buffer)
:new-position (if no-position
nil
(position-at-point (buffer-point buffer)))))
(defun %bookmark-apply-position (entry buffer)
(when (bookmark-position entry)
(move-to-position (buffer-point buffer) (bookmark-position entry))))
(defun prompt-for-bookmark (prompt)
(let ((candidates (loop :for entry :being :the :hash-value :in *bookmark-table*
:collect (lem/completion-mode:make-completion-item
:detail (if (bookmark-position entry)
(format nil "~a:~a" (bookmark-filename entry) (bookmark-position entry))
(format nil "~a" (bookmark-filename entry)))
:label (bookmark-name entry)))))
(prompt-for-string prompt
:completion-function (lambda (x) (completion-strings x candidates :key #'lem/completion-mode:completion-item-label))
:test-function (lambda (x) (find x candidates :test #'string= :key #'lem/completion-mode:completion-item-label))
:history-symbol 'prompt-for-bookmark)))
(defun load-from-file (file-path &optional (bookmark-table *bookmark-table*))
(with-open-file (input file-path :direction :input)
(loop :for bookmark-line :in (read input)
:do (let ((bookmark-entry (bookmark-deserialize bookmark-line)))
(setf (gethash (bookmark-name bookmark-entry) bookmark-table) bookmark-entry)))))
(define-command bookmark-load () ()
"Load bookmarks from the file specified in the *FILE*."
(let* ((file *file*)
(full-path (if (uiop:relative-pathname-p file)
(uiop:merge-pathnames* file (lem-home))
file)))
(handler-case (load-from-file full-path)
(sb-int:simple-file-error (c)
(editor-error "bookmark: ~a~&" c))))
nil)
(defun save-to-file (file-path &optional (bookmark-table *bookmark-table*))
(with-open-file (output file-path
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(write (loop :for entry :being :the :hash-value :in bookmark-table
:collect (bookmark-serialize entry))
:stream output)
(write-line "" output))
nil)
(define-command bookmark-save () ()
"Save bookmarks to *FILE*."
(let* ((file *file*)
(full-path (if (uiop:relative-pathname-p file)
(uiop:merge-pathnames* file (lem-home))
file)))
(handler-case (save-to-file full-path)
(sb-int:simple-file-error (c)
(editor-error "bookmark: ~a~&" c)))))
(define-command bookmark-set (name) ("sBookmark name: ")
"Set a new bookmark with NAME for the current buffer.
If a bookmark with NAME already exists, it will be overwritten.
If called interactively, prompt for NAME."
(unless (%bookmark-insert name (current-buffer))
(editor-error "bookmark: Buffer not visiting a file or directory~&")))
(define-command bookmark-set-no-position (name) ("sBookmark name: ")
"Set a new bookmark with NAME for the current buffer without position.
If a bookmark with NAME already exists, it wil be overwritten.
If called interactively, prompt for NAME."
(unless (%bookmark-insert name (current-buffer) :no-position t)
(editor-error "bookmark: Buffer not visiting a file or directory~&")))
(define-command bookmark-set-no-overwrite (name) ("sBookmark name: ")
"Set a new bookmark with NAME for the current buffer.
If a bookmark with NAME already exists, it will be left unchanged.
If called interactively, prompt for NAME."
(if (gethash name *bookmark-table*)
(editor-error "bookmark: ~a: Bookmark already exists~&" name)
(bookmark-set name)))
(define-command bookmark-set-no-position-no-overwrite (name) ("sBookmark name: ")
"Set a new bookmark with NAME for the current buffer without position.
If a bookmark with NAME already exists, it will be left unchanged.
If called interactively, prompt for NAME."
(if (gethash name *bookmark-table*)
(editor-error "bookmark: ~a: Bookmark already exists~&" name)
(bookmark-set-no-position name)))
(define-command bookmark-delete (name) ((prompt-for-bookmark "Delete bookmark: "))
"Delete the bookmark with NAME.
If called interactively, prompt for NAME."
(if (null (gethash name *bookmark-table*))
(editor-error "bookmark: ~a: Bookmark does not exist~&" name)
(%bookmark-delete (gethash name *bookmark-table*))))
(define-command bookmark-delete-all () ()
"Delete all bookmarks."
(setq *bookmark-table* (clrhash *bookmark-table*)))
(define-command bookmark-rename (old-name new-name) ((prompt-for-bookmark "Rename bookmark: ")
(prompt-for-string "New bookmark name: "))
"Rename the bookmark with OLD-NAME to NEW-NAME.
If a bookmark with NEW-NAME already exists, it will be overwritten.
If called interactively, prompt for OLD-NAME and NEW-NAME."
(let ((entry (gethash old-name *bookmark-table*)))
(if (null entry)
(editor-error "bookmark: ~a: Bookmark does not exist~&" old-name)
(%bookmark-update entry :new-name new-name))))
(define-command bookmark-rename-no-overwrite (old-name new-name) ((prompt-for-bookmark "Rename bookmark: ")
(prompt-for-string "New bookmark name: "))
"Rename the bookmark with OLD-NAME to NEW-NAME.
If a bookmark with NEW-NAME already exists, it will be left unchanged.
If called interactively, prompt for OLD-NAME and NEW-NAME."
(let ((entry (gethash old-name *bookmark-table*)))
(if (null entry)
(editor-error "bookmark: ~a: Bookmark does not exist~&" old-name)
(if (not (null (gethash new-name *bookmark-table*)))
(editor-error "bookmark: ~a Bookmark already exists~&" new-name)
(%bookmark-update entry :new-name new-name)))))
(define-command bookmark-relocate (name) ((prompt-for-bookmark "Relocate bookmark: "))
"Relocate the bookmark NAME to the position and file of the current buffer.
If called interactively, prompt for NAME."
(let ((entry (gethash name *bookmark-table*)))
(if (null entry)
(editor-error "bookmark: ~a: Bookmark does not exist~&" name)
(let ((buffer (current-buffer)))
(if (null (buffer-filename buffer))
(editor-error "bookmark: Buffer not visiting a file or directory~&")
(%bookmark-relocate entry buffer))))))
(define-command bookmark-jump (name) ((prompt-for-bookmark "Jump to bookmark: "))
"Jump to the bookmark with NAME in the current window.
If the bookmark is associated with a position, jump to it.
If called interactively, prompt for NAME."
(let ((entry (gethash name *bookmark-table*)))
(if (null entry)
(editor-error "bookmark: ~a: Bookmark does not exist~&" name)
(let ((buffer (find-file (bookmark-filename entry))))
(%bookmark-apply-position entry buffer)))))