source: trunk/source/contrib/foy/list-definitions/history-lists.lisp @ 12639

Last change on this file since 12639 was 12639, checked in by gfoy, 11 years ago

Added history-lists.lisp, supporting persistent file and position history lists.
File size: 23.6 KB
Line 
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)
Note: See TracBrowser for help on using the repository browser.