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

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

gui::cocoa-edit-single-definition no longer exists. It's difficult to redefne it.

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