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

Last change on this file since 12785 was 12785, checked in by gfoy, 10 years ago

Fixed add-top-level-position for objc.

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