1 | ;;;-*- Mode: Lisp; Package: LIST-DEFINITIONS -*- |
---|
2 | |
---|
3 | ;;; ---------------------------------------------------------------------------- |
---|
4 | ;;; |
---|
5 | ;;; history-lists.lisp |
---|
6 | ;;; |
---|
7 | ;;; copyright © 2009 Glen Foy |
---|
8 | ;;; (Permission is granted to Clozure Associates to distribute this file.) |
---|
9 | ;;; |
---|
10 | ;;; This code supports file and position history lists. |
---|
11 | ;;; |
---|
12 | ;;; Alt-Right-Click produces a most-recently-visited list of definition |
---|
13 | ;;; positions. Alt-Command-Right-Click produces a most-recently-visited |
---|
14 | ;;; list of files. Both lists are persistent and are stored here: |
---|
15 | ;;; |
---|
16 | ;;; ~/Library/Preferences/org.clairvaux/list-definitions/file-history |
---|
17 | ;;; ~/Library/Preferences/org.clairvaux/list-definitions/position-history |
---|
18 | ;;; |
---|
19 | ;;; This software is offered "as is", without warranty of any kind. |
---|
20 | ;;; |
---|
21 | ;;; Mod History, most recent first: |
---|
22 | ;;; 8/17/9 version 0.2b1 |
---|
23 | ;;; This file added. |
---|
24 | ;;; |
---|
25 | ;;; ---------------------------------------------------------------------------- |
---|
26 | |
---|
27 | (in-package "LIST-DEFINITIONS") |
---|
28 | |
---|
29 | (defParameter *position-history-list-length* 25) |
---|
30 | (defParameter *file-history-list-length* 25) |
---|
31 | |
---|
32 | ;;; This includes a work-around for what appears to be a bug in the hemlock-frame |
---|
33 | ;;; #/close method. After a #/close, the window remains on the (#/orderedWindows *NSApp*) |
---|
34 | ;;; list, but (hi::buffer-document buffer) in NIL. Therefore the extra tests: |
---|
35 | (defun window-with-path (path) |
---|
36 | "If a window with PATH is open, return it." |
---|
37 | (gui::first-window-satisfying-predicate |
---|
38 | #'(lambda (w) |
---|
39 | (when (and (typep w 'gui::hemlock-frame) |
---|
40 | (not (typep w 'gui::hemlock-listener-frame))) |
---|
41 | (let* ((pane (slot-value w 'gui::pane)) |
---|
42 | (text-view (gui::text-pane-text-view pane)) |
---|
43 | (buffer (gui::hemlock-buffer text-view)) |
---|
44 | (document (when buffer (hi::buffer-document buffer))) |
---|
45 | (p (hi::buffer-pathname buffer))) |
---|
46 | (when (and document p) (string-equal path p))))))) |
---|
47 | |
---|
48 | (defun maybe-open-file (path) |
---|
49 | "If a window with PATH is open, return it. Otherwise open a new window." |
---|
50 | (let ((w (window-with-path path))) |
---|
51 | (if w |
---|
52 | w |
---|
53 | (let ((hemlock-view (gui::cocoa-edit path))) |
---|
54 | (when hemlock-view (#/window (hi::hemlock-view-pane hemlock-view))))))) |
---|
55 | |
---|
56 | (defun construct-history-path (filename) |
---|
57 | "Construct the path to the history file." |
---|
58 | (merge-pathnames (concatenate 'string |
---|
59 | ";Library;Preferences;org.clairvaux;list-definitions;" |
---|
60 | filename) |
---|
61 | (hemlock::user-homedir-pathname))) |
---|
62 | |
---|
63 | (defun notify (message) |
---|
64 | "FYI" |
---|
65 | (gui::alert-window :title "Notification" :message message)) |
---|
66 | |
---|
67 | ;;; ---------------------------------------------------------------------------- |
---|
68 | ;;; |
---|
69 | (defClass HISTORY-LIST-ENTRY () |
---|
70 | ((name :initarg :name :reader hle-name) |
---|
71 | (path :initarg :path :reader hle-path)) |
---|
72 | (:documentation "Support for the history lists.")) |
---|
73 | |
---|
74 | ;;; ---------------------------------------------------------------------------- |
---|
75 | ;;; |
---|
76 | (defClass POSITION-LIST-ENTRY (history-list-entry) |
---|
77 | ((info :initarg :info :reader hle-info)) |
---|
78 | (:documentation "Support for the position history list.")) |
---|
79 | |
---|
80 | (defMethod show-entry ((entry position-list-entry)) |
---|
81 | "Display the file and scroll to position." |
---|
82 | (let* ((name (hle-name entry)) |
---|
83 | (path (hle-path entry)) |
---|
84 | (window (window-with-path path)) |
---|
85 | mark def-list text-view hemlock-view) |
---|
86 | (unless (probe-file path) |
---|
87 | (notify (format nil "~a does not exist. It will be deleted from the history lists." |
---|
88 | path)) |
---|
89 | (purge-file-references *position-history-list* path) |
---|
90 | (remove-path *file-history-list* path) |
---|
91 | (return-from show-entry nil)) |
---|
92 | (cond (window |
---|
93 | (setq hemlock-view (gui::hemlock-view window)) |
---|
94 | (setq text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view)))) |
---|
95 | (t |
---|
96 | (setq hemlock-view (gui::cocoa-edit path)) |
---|
97 | (when hemlock-view |
---|
98 | (setq window (#/window (hi::hemlock-view-pane hemlock-view))) |
---|
99 | (setq text-view (gui::text-pane-text-view (hi::hemlock-view-pane hemlock-view)))))) |
---|
100 | (when window |
---|
101 | (#/makeKeyAndOrderFront: window nil) |
---|
102 | (setq def-list (list-definitions window)) |
---|
103 | (setq mark (cdr (assoc name def-list |
---|
104 | :test #'string-equal |
---|
105 | :key #'(lambda (def-info) |
---|
106 | (let ((def-type (first def-info))) |
---|
107 | (if (or (eq def-type :defmethod) |
---|
108 | (eq def-type :objc)) |
---|
109 | (third def-info) |
---|
110 | (second def-info))))))) |
---|
111 | (cond (mark |
---|
112 | (display-position text-view mark) |
---|
113 | (move-entry-to-front *file-history-list* path) t) |
---|
114 | (t |
---|
115 | (notify (format nil "Cannot find ~S. It will be deleted from the position history list." |
---|
116 | name)) |
---|
117 | (remove-entry *position-history-list* name) nil))))) |
---|
118 | |
---|
119 | ;;; ---------------------------------------------------------------------------- |
---|
120 | ;;; |
---|
121 | (defClass FILE-LIST-ENTRY (history-list-entry) |
---|
122 | ((short-path :initarg :short-path :accessor hle-short-path)) |
---|
123 | (:documentation "Support for the file history list.")) |
---|
124 | |
---|
125 | (defMethod show-entry ((entry file-list-entry)) |
---|
126 | (let ((path (hle-path entry))) |
---|
127 | (unless (probe-file path) |
---|
128 | (notify (format nil "~S does not exist. It will be deleted from the history lists." path)) |
---|
129 | (purge-file-references *position-history-list* path) |
---|
130 | (remove-path *file-history-list* path) |
---|
131 | (return-from show-entry nil)) |
---|
132 | (let ((window (window-with-path path))) |
---|
133 | (unless window |
---|
134 | (let ((hemlock-view (gui::cocoa-edit path))) |
---|
135 | (when hemlock-view |
---|
136 | (setq window (#/window (hi::hemlock-view-pane hemlock-view)))))) |
---|
137 | (when window |
---|
138 | (#/makeKeyAndOrderFront: window nil) t)))) |
---|
139 | |
---|
140 | ;;; ---------------------------------------------------------------------------- |
---|
141 | ;;; |
---|
142 | (defClass HISTORY-LIST () |
---|
143 | ((capacity :initarg :capacity :reader hl-capacity) |
---|
144 | (path :initarg :path :reader hl-path) |
---|
145 | (list :initform nil :accessor hl-list)) |
---|
146 | (:documentation "Super class of position-history-list and file-history-list.")) |
---|
147 | |
---|
148 | ;;; ---------------------------------------------------------------------------- |
---|
149 | ;;; |
---|
150 | (defClass POSITION-HISTORY-LIST (history-list) |
---|
151 | () |
---|
152 | (:documentation "A persistent history list of most-recently-visited definition positions.")) |
---|
153 | |
---|
154 | (setq *position-history-list* (make-instance 'position-history-list |
---|
155 | :path (construct-history-path "position-history") |
---|
156 | :capacity *position-history-list-length*)) |
---|
157 | |
---|
158 | (defMethod find-entry ((hl position-history-list) name) |
---|
159 | (find-if #'(lambda (entry) (string-equal name (hle-name entry))) |
---|
160 | (hl-list hl))) |
---|
161 | |
---|
162 | (defMethod move-entry-to-front ((hl position-history-list) name) |
---|
163 | (let ((entry (find-entry hl name))) |
---|
164 | (when entry |
---|
165 | (setf (hl-list hl) |
---|
166 | (cons entry (delete name (hl-list hl) :test #'string-equal :key #'hle-name))) |
---|
167 | entry))) |
---|
168 | |
---|
169 | (defMethod purge-file-references ((hl position-history-list) path) |
---|
170 | (setf (hl-list hl) (delete-if #'(lambda (entry) |
---|
171 | (equal (hle-path entry) path)) |
---|
172 | (hl-list hl)))) |
---|
173 | |
---|
174 | (defMethod remove-entry ((hl position-history-list) name) |
---|
175 | (setf (hl-list hl) (delete name (hl-list hl) :test #'string-equal :key #'hle-name))) |
---|
176 | |
---|
177 | (defMethod add-history-entry ((hl position-history-list) def-info path) |
---|
178 | (let* ((def-type (first def-info)) |
---|
179 | (name (second def-info)) |
---|
180 | (signature (third def-info)) |
---|
181 | (entry (make-instance 'position-list-entry |
---|
182 | :name (if (or (eq def-type :defmethod) |
---|
183 | (eq def-type :objc)) |
---|
184 | signature |
---|
185 | name) |
---|
186 | :info def-info :path path))) |
---|
187 | (setf (hl-list hl) (cons entry (hl-list hl))) |
---|
188 | entry)) |
---|
189 | |
---|
190 | (defMethod maybe-add-history-entry ((hl position-history-list) def-info path) |
---|
191 | (let* ((def-type (first def-info)) |
---|
192 | (name (if (or (eq def-type :defmethod) |
---|
193 | (eq def-type :objc)) |
---|
194 | (third def-info) |
---|
195 | (second def-info)))) |
---|
196 | (cond ((member name (hl-list hl) :test #'string-equal :key #'hle-name) |
---|
197 | ;; it's there; move it to the front: |
---|
198 | (move-entry-to-front hl name)) |
---|
199 | (t |
---|
200 | (when (>= (length (hl-list hl)) (hl-capacity hl)) |
---|
201 | ;; bump the last entry, then add: |
---|
202 | (setf (hl-list hl) (butlast (hl-list hl)))) |
---|
203 | (add-history-entry hl def-info path))))) |
---|
204 | |
---|
205 | (defun clear-position-history-list() |
---|
206 | "Remove all the entries from the position history list." |
---|
207 | (setf (hl-list *position-history-list*) nil)) |
---|
208 | |
---|
209 | ;;; ---------------------------------------------------------------------------- |
---|
210 | ;;; |
---|
211 | (defClass FILE-HISTORY-LIST (history-list) |
---|
212 | () |
---|
213 | (:documentation "A persistent history list of most-recently-visited files.")) |
---|
214 | |
---|
215 | (setf *file-history-list* (make-instance 'file-history-list |
---|
216 | :path (construct-history-path "file-history") |
---|
217 | :capacity *file-history-list-length*)) |
---|
218 | |
---|
219 | (defMethod find-entry ((hl file-history-list) path) |
---|
220 | (find-if #'(lambda (entry) (string-equal path (hle-path entry))) |
---|
221 | (hl-list hl))) |
---|
222 | |
---|
223 | (defMethod move-entry-to-front ((hl file-history-list) path) |
---|
224 | (let ((entry (find-entry hl path))) |
---|
225 | (when entry |
---|
226 | (setf (hl-list hl) |
---|
227 | (cons entry (delete path (hl-list hl) :test #'string-equal :key #'hle-path))) |
---|
228 | entry))) |
---|
229 | |
---|
230 | (defmethod remove-path ((hl file-history-list) path) |
---|
231 | (setf (hl-list hl) (delete path (hl-list hl) |
---|
232 | :test #'string-equal :key #'hle-path))) |
---|
233 | |
---|
234 | (defMethod add-history-entry ((hl file-history-list) name path) |
---|
235 | (let* ((name-position (position #\/ path :test #'char= :from-end t)) |
---|
236 | (short-path (when name-position (subseq path 0 (incf name-position)))) |
---|
237 | (entry (when short-path (make-instance 'file-list-entry :name name |
---|
238 | :short-path short-path :path path)))) |
---|
239 | (when entry |
---|
240 | (setf (hl-list hl) (cons entry (hl-list hl))) |
---|
241 | entry))) |
---|
242 | |
---|
243 | (defMethod maybe-add-history-entry ((hl file-history-list) name path) |
---|
244 | (cond ((member path (hl-list hl) :test #'string-equal :key #'hle-path) |
---|
245 | (move-entry-to-front hl path)) |
---|
246 | (t |
---|
247 | (cond ((< (length (hl-list hl)) (hl-capacity hl)) |
---|
248 | (add-history-entry hl name path)) |
---|
249 | (t |
---|
250 | (setf (hl-list hl) (butlast (hl-list hl))) |
---|
251 | (add-history-entry hl name path)))))) |
---|
252 | |
---|
253 | (defun clear-file-history-list () |
---|
254 | "Remove all the entries from the file history list." |
---|
255 | (setf (hl-list *file-history-list*) nil)) |
---|
256 | |
---|
257 | ;;; ---------------------------------------------------------------------------- |
---|
258 | ;;; |
---|
259 | (defclass POSITION-MENU-ITEM (ns:ns-menu-item) |
---|
260 | ((path :accessor position-path) |
---|
261 | (name :accessor position-name)) |
---|
262 | (:documentation "Support for the positions popup menu.") |
---|
263 | (:metaclass ns:+ns-object)) |
---|
264 | |
---|
265 | ;;; ---------------------------------------------------------------------------- |
---|
266 | ;;; |
---|
267 | (defclass POSITIONS-MENU (ns:ns-menu) |
---|
268 | () |
---|
269 | (:documentation "A popup menu of most-recently-visited definition positions.") |
---|
270 | (:metaclass ns:+ns-object)) |
---|
271 | |
---|
272 | ;;; Pressing the shift key when selecting an entry will delete the entry: |
---|
273 | (objc:defmethod (#/positionHistoryAction: :void) ((m positions-menu) (sender :id)) |
---|
274 | (let ((entry (find-entry *position-history-list* (position-name sender)))) |
---|
275 | (when entry |
---|
276 | (cond ((gui::current-event-modifier-p #$NSShiftKeyMask) |
---|
277 | (remove-entry *position-history-list* (position-name sender))) |
---|
278 | (t |
---|
279 | (show-entry entry) |
---|
280 | (move-entry-to-front *position-history-list* (position-name sender))))))) |
---|
281 | |
---|
282 | (objc:defmethod (#/clearPositionHistoryAction: :void) ((m positions-menu) (sender :id)) |
---|
283 | (declare (ignore sender)) |
---|
284 | (clear-position-history-list)) |
---|
285 | |
---|
286 | (defun positions-context-menu () |
---|
287 | "Create the positions context menu." |
---|
288 | (let* ((menu (make-instance 'positions-menu)) |
---|
289 | (class-icon (#/iconForFileType: (#/sharedWorkspace ns:ns-workspace) (ccl::%make-nsstring "lisp"))) |
---|
290 | menu-item) |
---|
291 | (ns:with-ns-size (icon-size 16 16) |
---|
292 | (#/setSize: class-icon icon-size)) |
---|
293 | (dolist (entry (hl-list *position-history-list*)) |
---|
294 | (let* ((def-info (hle-info entry)) |
---|
295 | (def-type (first def-info)) |
---|
296 | (name (second def-info)) |
---|
297 | (signature (third def-info)) |
---|
298 | (dictionary (case def-type |
---|
299 | (:defclass *defclass-dictionary*) |
---|
300 | (:defstruct *defstruct-dictionary*) |
---|
301 | (:defmethod *defmethod-dictionary*) |
---|
302 | (:defun *defun-dictionary*) |
---|
303 | (:defmacro *defmacro-dictionary*) |
---|
304 | (:objc *objc-dictionary*) |
---|
305 | (t *generic-dictionary*))) |
---|
306 | (attributed-string (#/initWithString:attributes: |
---|
307 | (#/alloc ns:ns-attributed-string) |
---|
308 | (if (or (eq def-type :defmethod) |
---|
309 | (eq def-type :objc)) |
---|
310 | (ccl::%make-nsstring signature) |
---|
311 | (ccl::%make-nsstring name)) |
---|
312 | dictionary))) |
---|
313 | (setq menu-item (make-instance 'position-menu-item)) |
---|
314 | (setf (position-path menu-item) (hle-path entry)) |
---|
315 | (if (or (eq def-type :defmethod) (eq def-type :objc)) |
---|
316 | (setf (position-name menu-item) signature) |
---|
317 | (setf (position-name menu-item) name)) |
---|
318 | (#/setAttributedTitle: menu-item attributed-string) |
---|
319 | ;; Classes have a prepended CCL icon: |
---|
320 | (when (eq def-type :defclass) (#/setImage: menu-item class-icon)) |
---|
321 | (#/setAction: menu-item (ccl::@selector "positionHistoryAction:")) |
---|
322 | (#/setTarget: menu-item menu) |
---|
323 | (#/addItem: menu menu-item))) |
---|
324 | (#/addItem: menu (#/separatorItem ns:ns-menu-item)) |
---|
325 | (let ((attributed-string (#/initWithString:attributes: |
---|
326 | (#/alloc ns:ns-attributed-string) |
---|
327 | (ccl::%make-nsstring "Clear List") |
---|
328 | *generic-dictionary*))) |
---|
329 | (setq menu-item (make-instance 'ns:ns-menu-item)) |
---|
330 | (#/setAttributedTitle: menu-item attributed-string) |
---|
331 | (#/setTarget: menu-item menu) |
---|
332 | (#/setAction: menu-item (ccl::@selector "clearPositionHistoryAction:")) |
---|
333 | (#/addItem: menu menu-item)) |
---|
334 | menu)) |
---|
335 | |
---|
336 | ;;; ---------------------------------------------------------------------------- |
---|
337 | ;;; |
---|
338 | (defclass FILE-MENU-ITEM (ns:ns-menu-item) |
---|
339 | ((path :accessor file-path) |
---|
340 | (name :accessor file-name)) |
---|
341 | (:documentation "Support for the files popup menu.") |
---|
342 | (:metaclass ns:+ns-object)) |
---|
343 | |
---|
344 | ;;; ---------------------------------------------------------------------------- |
---|
345 | ;;; |
---|
346 | (defclass FILE-MENU (ns:ns-menu) |
---|
347 | () |
---|
348 | (:documentation "A popup menu of most-recently-visited files.") |
---|
349 | (:metaclass ns:+ns-object)) |
---|
350 | |
---|
351 | ;;; Pressing the shift key when selecting an entry will delete the entry: |
---|
352 | (objc:defmethod (#/fileHistoryAction: :void) ((m file-menu) (sender :id)) |
---|
353 | (let ((entry (find-entry *file-history-list* (file-path sender)))) |
---|
354 | (when entry |
---|
355 | (cond ((gui::current-event-modifier-p #$NSShiftKeyMask) |
---|
356 | (remove-path *file-history-list* (file-path sender))) |
---|
357 | (t |
---|
358 | (show-entry entry) |
---|
359 | (move-entry-to-front *file-history-list* (file-path sender))))))) |
---|
360 | |
---|
361 | (objc:defmethod (#/clearFileHistoryAction: :void) ((m file-menu) (sender :id)) |
---|
362 | (declare (ignore sender)) |
---|
363 | (clear-file-history-list)) |
---|
364 | |
---|
365 | (defun files-context-menu () |
---|
366 | "Create the files context menu." |
---|
367 | (let* ((menu (make-instance 'file-menu)) |
---|
368 | menu-item) |
---|
369 | (dolist (entry (hl-list *file-history-list*)) |
---|
370 | (let ((attributed-string (#/initWithString:attributes: |
---|
371 | (#/alloc ns:ns-attributed-string) |
---|
372 | (ccl::%make-nsstring |
---|
373 | (format nil "~A ~A" |
---|
374 | (hle-name entry) |
---|
375 | (hle-short-path entry))) |
---|
376 | *file-history-dictionary*))) |
---|
377 | (setq menu-item (make-instance 'file-menu-item)) |
---|
378 | (setf (file-name menu-item) (hle-name entry)) |
---|
379 | (setf (file-path menu-item) (hle-path entry)) |
---|
380 | (#/setAttributedTitle: menu-item attributed-string) |
---|
381 | (#/setAction: menu-item (ccl::@selector "fileHistoryAction:")) |
---|
382 | (#/setTarget: menu-item menu) |
---|
383 | (#/addItem: menu menu-item))) |
---|
384 | (#/addItem: menu (#/separatorItem ns:ns-menu-item)) |
---|
385 | (let ((attributed-string (#/initWithString:attributes: |
---|
386 | (#/alloc ns:ns-attributed-string) |
---|
387 | (ccl::%make-nsstring "Clear List") |
---|
388 | *generic-dictionary*))) |
---|
389 | (setq menu-item (make-instance 'ns:ns-menu-item)) |
---|
390 | (#/setAttributedTitle: menu-item attributed-string) |
---|
391 | (#/setTarget: menu-item menu) |
---|
392 | (#/setAction: menu-item (ccl::@selector "clearFileHistoryAction:")) |
---|
393 | (#/addItem: menu menu-item)) |
---|
394 | menu)) |
---|
395 | |
---|
396 | ;;; ---------------------------------------------------------------------------- |
---|
397 | ;;; File I/O |
---|
398 | ;;; |
---|
399 | (defun read-history-files () |
---|
400 | "Read the position and file history lists." |
---|
401 | (let ((path (hl-path *file-history-list*))) |
---|
402 | (when (probe-file path) |
---|
403 | (with-open-file (stream path :direction :input) |
---|
404 | (read-history-list *file-history-list* stream)))) |
---|
405 | (let ((path (hl-path *position-history-list*))) |
---|
406 | (when (probe-file path) |
---|
407 | (with-open-file (stream path :direction :input) |
---|
408 | (read-history-list *position-history-list* stream t))))) |
---|
409 | |
---|
410 | (defMethod read-history-list ((hl history-list) stream &optional position-p) |
---|
411 | (flet ((oops () |
---|
412 | (notify (format nil "There is a problem with ~S. Setting the history to NIL." (hl-path hl))) |
---|
413 | (setf (hl-list hl) nil) |
---|
414 | ;;; delete the file? |
---|
415 | (return-from read-history-list))) |
---|
416 | (setf (hl-list hl) nil) |
---|
417 | ;; For the position-history-list, ufo is the def-info list. |
---|
418 | ;; For the file-history-list, ufo is the filename string. |
---|
419 | (let (length ufo path input) |
---|
420 | (setf input (read stream nil :eof)) |
---|
421 | (unless (numberp input) (oops)) |
---|
422 | (setf length input) |
---|
423 | (dotimes (count length t) |
---|
424 | (setf input (read stream nil :eof)) |
---|
425 | (when (or (eql input :eof) |
---|
426 | (if position-p |
---|
427 | (not (listp input)) |
---|
428 | (not (stringp input)))) |
---|
429 | (oops)) |
---|
430 | (setf ufo input) |
---|
431 | (setf input (read stream nil :eof)) |
---|
432 | (when (or (eql input :eof) |
---|
433 | (not (stringp input))) |
---|
434 | (oops)) |
---|
435 | (setf path input) |
---|
436 | (when (null (add-history-entry hl ufo path)) |
---|
437 | (oops)))))) |
---|
438 | |
---|
439 | (defMethod write-history-list ((hl position-history-list) stream) |
---|
440 | (format stream "~s~%" (length (hl-list hl))) |
---|
441 | (dolist (entry (nreverse (hl-list hl))) |
---|
442 | (format stream "~s~%" (hle-info entry)) |
---|
443 | (format stream "~s~%" (hle-path entry)))) |
---|
444 | |
---|
445 | (defMethod write-history-list ((hl file-history-list) stream) |
---|
446 | (format stream "~s~%" (length (hl-list hl))) |
---|
447 | (dolist (entry (nreverse (hl-list hl))) |
---|
448 | (format stream "~s~%" (hle-name entry)) |
---|
449 | (format stream "~s~%" (hle-path entry)))) |
---|
450 | |
---|
451 | (defun write-history-files () |
---|
452 | "Write the history list entries to the path." |
---|
453 | (let ((path (hl-path *position-history-list*))) |
---|
454 | (with-open-file (stream path :direction :output :if-exists :supersede) |
---|
455 | (write-history-list *position-history-list* stream))) |
---|
456 | (let ((path (hl-path *file-history-list*))) |
---|
457 | (with-open-file (stream path :direction :output :if-exists :supersede) |
---|
458 | (write-history-list *file-history-list* stream)))) |
---|
459 | |
---|
460 | (defun write-history-files-on-shutdown (&rest args) |
---|
461 | "Writing function pushed into *lisp-cleanup-functions*." |
---|
462 | (declare (ignore args)) |
---|
463 | (write-history-files)) |
---|
464 | |
---|
465 | (defun read-history-files-on-startup (&rest args) |
---|
466 | "Reading function (eventually) pushed into *lisp-startup-functions*." |
---|
467 | (declare (ignore args)) |
---|
468 | (read-history-files)) |
---|
469 | |
---|
470 | (pushnew 'write-history-files-on-shutdown ccl::*lisp-cleanup-functions*) |
---|
471 | |
---|
472 | ;;; To Do: |
---|
473 | ;;; Heap issues involved in saving an image with the utility loaded. |
---|
474 | ;;; (pushnew 'read-history-files-on-startup ccl::*lisp-startup-functions*) |
---|
475 | |
---|
476 | ;;; ---------------------------------------------------------------------------- |
---|
477 | ;;; File History Interface: |
---|
478 | ;;; |
---|
479 | (objc:defmethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame)) |
---|
480 | (let* ((path (window-path w)) |
---|
481 | (name (when (and path (string-equal (pathname-type path) "lisp")) |
---|
482 | (concatenate 'string (pathname-name path) ".lisp")))) |
---|
483 | (when (and name path) |
---|
484 | (maybe-add-history-entry *file-history-list* name path)) |
---|
485 | (call-next-method))) |
---|
486 | |
---|
487 | ;;; ---------------------------------------------------------------------------- |
---|
488 | ;;; Position History Interface: |
---|
489 | ;;; |
---|
490 | (hemlock::defcommand "Add Definition Position" (p) |
---|
491 | "Add the position of the definition containing point to *position-history-list*." |
---|
492 | (declare (ignore p)) |
---|
493 | (let* ((buffer (hemlock::current-buffer)) |
---|
494 | (mark (hi::copy-mark (hemlock::buffer-point buffer) :temporary)) |
---|
495 | (path (hi::buffer-pathname buffer)) |
---|
496 | (start-mark (hi::top-level-offset mark -1)) |
---|
497 | (def-info (when start-mark (definition-info start-mark)))) |
---|
498 | (when (and def-info path) |
---|
499 | (maybe-add-history-entry *position-history-list* def-info path)))) |
---|
500 | |
---|
501 | (hemlock::bind-key "Add Definition Position" #k"control-shift-space") |
---|
502 | |
---|
503 | ;;; *** buffer? |
---|
504 | (defun add-top-level-position (&optional buffer) |
---|
505 | "Maybe add the top-level definition position to the position history list." |
---|
506 | (let* ((buf (or buffer (hi::current-buffer))) |
---|
507 | (mark (hi::copy-mark (hemlock::buffer-point buf) :temporary)) |
---|
508 | (path (hi::buffer-pathname buf)) |
---|
509 | start-mark def-info) |
---|
510 | (if (and (= (hi::mark-charpos mark) 0) |
---|
511 | (char= (hi::next-character mark) #\()) |
---|
512 | (setq start-mark mark) |
---|
513 | (setq start-mark (hemlock::top-level-offset mark -1))) |
---|
514 | (when start-mark |
---|
515 | (setq def-info (definition-info start-mark)) |
---|
516 | (when (and def-info path) |
---|
517 | (maybe-add-history-entry *position-history-list* def-info path))))) |
---|
518 | |
---|
519 | ;;; *** These three redefinitions are not a great way of doing this *** |
---|
520 | ;;; *** Where's CLOS when you need it ... |
---|
521 | (hemlock::defcommand "Editor Evaluate Defun" (p) |
---|
522 | "Evaluates the current or next top-level form in the editor Lisp. |
---|
523 | If the current region is active, this evaluates the region." |
---|
524 | "Evaluates the current or next top-level form in the editor Lisp." |
---|
525 | (declare (ignore p)) |
---|
526 | (if (hemlock::region-active-p) |
---|
527 | (hemlock::editor-evaluate-region-command nil) |
---|
528 | (hemlock::eval-region (hemlock::defun-region (hi::current-point)))) |
---|
529 | (add-top-level-position)) |
---|
530 | |
---|
531 | (hemlock::defcommand "Editor Compile Defun" (p) |
---|
532 | "Compiles the current or next top-level form in the editor Lisp. |
---|
533 | First the form is evaluated, then the result of this evaluation |
---|
534 | is passed to compile. If the current region is active, this |
---|
535 | compiles the region." |
---|
536 | "Evaluates the current or next top-level form in the editor Lisp." |
---|
537 | (declare (ignore p)) |
---|
538 | (if (hemlock::region-active-p) |
---|
539 | (hemlock::editor-compile-region (hemlock::current-region)) |
---|
540 | (hemlock::editor-compile-region (hemlock::defun-region (hi::current-point)) t)) |
---|
541 | (add-top-level-position)) |
---|
542 | |
---|
543 | (defun gui::cocoa-edit-single-definition (name info) |
---|
544 | (gui::assume-cocoa-thread) |
---|
545 | (destructuring-bind (indicator . pathname) info |
---|
546 | (let* ((view (gui::find-or-make-hemlock-view pathname)) |
---|
547 | (buffer (hi::hemlock-view-buffer view))) |
---|
548 | (hi::handle-hemlock-event view |
---|
549 | #'(lambda () |
---|
550 | (hemlock::find-definition-in-buffer name indicator))) |
---|
551 | (add-top-level-position buffer)))) |
---|
552 | |
---|
553 | |
---|
554 | (read-history-files) |
---|
555 | |
---|
556 | (provide :list-definitions) |
---|