source: trunk/cocoa-ide-contrib/foy/context-menu-cm/context-menu.lisp @ 14985

Last change on this file since 14985 was 14985, checked in by gfoy, 9 years ago

Updates for ccl 1.7

File size: 12.2 KB
Line 
1;;;-*-Mode: LISP; Package: CONTEXT-MENU -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      context-menu.lisp
6;;;
7;;;      copyright (c) 2009 Glen Foy
8;;;      (Permission is granted to Clozure Associates to distribute this file.)
9;;;
10;;;      This code provides a mechanism for switching the tool that has access to
11;;;      Hemlock's contextual popup menu.  This is an initial prototype, implementing
12;;;      what may be the simplest approach.
13;;;
14;;;      The API for writing new tools is described in the accompanying NewTools file.
15;;;
16;;;      This software is offered "as is", without warranty of any kind.
17;;;
18;;;      Mod History, most recent first:
19;;;      8/14/11 Added a "save histories" context menu-item.
20;;;      1/6/10  Bogus param to format in add-default-tool-menu.
21;;;      9/2/9   Changed the appearance of the Default Tool submenu.
22;;;      8/31/9  version 0.1b1
23;;;              First cut
24;;;              Numerous User Interface suggestions, Rainer Joswig
25;;;
26;;; ----------------------------------------------------------------------------
27
28(defPackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
29(in-package "CONTEXT-MENU")
30
31(export '(register-tool add-default-tool-menu update-tool-menu set-default-tool
32          tool-menu *hemlock-menu-dictionary* *tool-label-dictionary* *tool-doc-dictionary*
33          *tool-key-dictionary* *dark-blue-color* *dark-turquoise-color* *light-gray-color* 
34          *wine-red-color* check-hyperspec-availability))
35
36(defParameter *menu-manager* nil "The context-menu-manager instance.")
37
38(defParameter *DARK-BLUE-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
39(defParameter *DARK-TURQUOISE-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.28 0.28 1.0))
40(defParameter *WINE-RED-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
41(defParameter *LIGHT-GRAY-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
42
43(defParameter *HEMLOCK-MENU-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
44(#/setObject:forKey: *hemlock-menu-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
45(#/setObject:forKey: *hemlock-menu-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
46
47(defParameter *TOOL-LABEL-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
48(#/setObject:forKey: *tool-label-dictionary* (#/systemFontOfSize: ns:ns-font (#/systemFontSize ns:ns-font)) #&NSFontAttributeName)
49(#/setObject:forKey: *tool-label-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
50
51(defParameter *TOOL-DOC-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
52(#/setObject:forKey: *tool-doc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
53(#/setObject:forKey: *tool-doc-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
54
55(defParameter *TOOL-KEY-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
56(#/setObject:forKey: *tool-key-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
57(#/setObject:forKey: *tool-key-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
58
59;;; ----------------------------------------------------------------------------
60;;;
61(defClass CONTEXT-MENU-MANAGER ()
62  ((tool-alist :initform nil :accessor tool-alist)
63   (default-tool :initform nil :accessor default-tool))
64  (:documentation "A class to manage Hemlock's contextual popup menu, supporting access by multiple tools."))
65
66(defMethod display-menu ((manager context-menu-manager) view event)
67  (when (default-tool manager)
68    (let ((entry (assoc (default-tool manager) (tool-alist manager) :test #'string-equal)))
69      (when entry 
70        (funcall (cdr entry) view event)))))
71
72(objc:defmethod #/menuForEvent: ((view gui::hemlock-text-view) (event :id))
73  (display-menu *menu-manager* view event))
74
75(defun REGISTER-TOOL (tool-name menu-function)
76  "Register the new tool with the menu-manager.  The last tool registered becomes the default tool."
77  (let ((entry (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car)))
78    (cond (entry
79           (gui::alert-window :title "Notification" :message (format nil "Re-registering ~S." tool-name))
80           (setf (tool-alist *menu-manager*) (delete tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))
81           (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*))))           
82          (t
83           (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*)))
84           (setf (tool-alist *menu-manager*)
85                 (sort (tool-alist *menu-manager*) #'string< :key #'car))
86           (set-default-tool tool-name)))))
87
88(defun SET-DEFAULT-TOOL (tool-name)
89  "Set the menu-manager's default tool.  Right-Click will display this tool's menu."
90  (let ((registered-name (car (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))))
91    (if registered-name
92      (setf (default-tool *menu-manager*) registered-name) ; keep the original capitalization
93      (gui::alert-window :title "Notification" :message (format nil "~S is not a registered tool.  It can't be set as default." tool-name)))))
94
95;;; ----------------------------------------------------------------------------
96;;;
97(defClass DEFAULT-TOOL-MENU-ITEM (ns:ns-menu-item)
98  ((name :accessor tool-name)) ; Lisp string
99  (:documentation "Support for the Tool submenu.")
100  (:metaclass ns:+ns-object))
101
102;;; ----------------------------------------------------------------------------
103;;;
104(defClass DEFAULT-TOOL-DOC-MENU-ITEM (ns:ns-menu-item)
105  ((filename :accessor tool-filename))
106  (:documentation "A menu-item to display the default tool's documentation.")
107  (:metaclass ns:+ns-object))
108
109;;; ----------------------------------------------------------------------------
110;;;
111(defClass DEFAULT-TOOL-MENU (ns:ns-menu)
112  ()
113  (:documentation "A submenu displaying all registered tools.")
114  (:metaclass ns:+ns-object))
115
116(objc:defmethod (#/hemlockDefaultToolAction: :void) ((m default-tool-menu) (sender :id))
117  (set-default-tool (tool-name sender)))
118
119(objc:defmethod (#/hemlockDefaultToolDocAction: :void) ((m default-tool-menu) (sender :id))
120  (display-doc (tool-filename sender)))
121
122;;; silence the compiler:
123(defPackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
124(declaim (ftype function ldefs::write-history-files))
125
126(objc:defmethod (#/hemlockDefaultToolHistoryAction: :void) ((m default-tool-menu) (sender :id))
127  (declare (ignore sender))
128  (ldefs::write-history-files))
129
130(defun display-doc (path)
131  "Display the default tool's documentation."
132  (when (probe-file path)
133    (#/openFile:withApplication: (#/sharedWorkspace ns:ns-workspace) 
134                                 (ccl::%make-nsstring (namestring path))
135                                 (ccl::%make-nsstring "TextEdit"))))
136 
137(defMethod populate-menu ((menu default-tool-menu))
138  (dotimes (count (#/numberOfItems menu))
139    (#/removeItemAtIndex: menu 0))
140  (flet ((create-menu-item (name)
141           (let ((menu-item (make-instance 'default-tool-menu-item))
142                 (attributed-string (#/initWithString:attributes:
143                                     (#/alloc ns:ns-attributed-string) 
144                                     (ccl::%make-nsstring name)
145                                     *tool-label-dictionary*)))
146             (setf (tool-name menu-item) name) 
147             (#/setAttributedTitle: menu-item attributed-string)
148             (#/setAction: menu-item (ccl::@selector "hemlockDefaultToolAction:"))
149             (#/setTarget: menu-item  menu)
150             (if (string-equal name (default-tool *menu-manager*))
151               (#/setState: menu-item #$NSOnState)
152               (#/setState: menu-item #$NSOffState))
153             (#/addItem: menu menu-item))))
154    (dolist (entry (tool-alist *menu-manager*))
155      (create-menu-item (car entry)))))
156
157(defun ADD-DEFAULT-TOOL-MENU (menu &key doc-file)
158  "Add the default tool submenu and possibly a documentation menu-item to MENU."
159  (let ((default-item (make-instance ns:ns-menu-item))
160        (tool-menu (make-instance 'default-tool-menu)))
161    ;; Title is set by update method.
162    (#/setSubmenu: default-item tool-menu)
163    (#/insertItem:atIndex: menu default-item 0)
164    (cond (doc-file
165           (let ((doc-item (make-instance 'default-tool-doc-menu-item))
166                 (attributed-string (#/initWithString:attributes:
167                                     (#/alloc ns:ns-attributed-string) 
168                                     (ccl::%make-nsstring (format nil "     doc..."))
169                                     *tool-doc-dictionary*))
170                 (save-histories-item (make-instance 'default-tool-doc-menu-item))
171                 (attributed-string-2 (#/initWithString:attributes:
172                                     (#/alloc ns:ns-attributed-string) 
173                                     (ccl::%make-nsstring (format nil "     save histories"))
174                                     *tool-doc-dictionary*)))
175             (#/setAttributedTitle: doc-item attributed-string)
176             (#/setAction: doc-item (ccl::@selector "hemlockDefaultToolDocAction:"))
177             (#/setTarget: doc-item  tool-menu)
178             (setf (tool-filename doc-item) doc-file)
179             (#/insertItem:atIndex: menu doc-item 1)
180
181             (#/setAttributedTitle: save-histories-item attributed-string-2)
182             (#/setAction: save-histories-item (ccl::@selector "hemlockDefaultToolHistoryAction:"))
183             (#/setTarget: save-histories-item  tool-menu)
184;;             (setf (tool-filename doc-item) doc-file)
185             (#/insertItem:atIndex: menu save-histories-item 2))
186          (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 3))
187          (t
188           (let ((save-histories-item (make-instance 'default-tool-doc-menu-item))
189                 (attributed-string-2 (#/initWithString:attributes:
190                                     (#/alloc ns:ns-attributed-string) 
191                                     (ccl::%make-nsstring (format nil "     save histories"))
192                                     *tool-doc-dictionary*)))
193             (#/setAttributedTitle: save-histories-item attributed-string-2)
194             (#/setAction: save-histories-item (ccl::@selector "hemlockDefaultToolHistoryAction:"))
195             (#/setTarget: save-histories-item  tool-menu)
196;;             (setf (tool-filename save-histories-item) nil)
197             (#/insertItem:atIndex: menu save-histories-item 1)
198             (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 2))))
199    tool-menu))
200
201(defun UPDATE-TOOL-MENU (menu default-menu &key sub-title)
202  "Update MENU's Tool submenu."
203  (let ((first-item (#/itemAtIndex: menu 0))
204        (attributed-string (#/initWithString:attributes:
205                            (#/alloc ns:ns-attributed-string) 
206                            (if sub-title
207                              (ccl::%make-nsstring (format nil "~S
208    (~A)" (default-tool *menu-manager*) sub-title))
209                              (ccl::%make-nsstring (format nil "~S" (default-tool *menu-manager*))))
210                            *tool-label-dictionary*)))
211    (#/setAttributedTitle: first-item attributed-string)
212    (populate-menu default-menu)))
213
214(let (checked-p)
215(defun CHECK-HYPERSPEC-AVAILABILITY (tool-name)
216  "Some tools require the HyperSpec."
217  (unless (or checked-p gui::*hyperspec-root-url*)
218    (rlet ((perror :id  +null-ptr+))
219      (let* ((map-url (make-instance 'ns:ns-url :with-string #@"Data/Map_Sym.txt" :relative-to-url (gui::hyperspec-root-url)))
220             ;; kludge alert:
221             (data (make-instance 'ns:ns-data
222                     :with-contents-of-url map-url
223                     :options 0
224                     :error perror)))
225        (declare (ignore data))
226        (setq checked-p t)
227        (unless (%null-ptr-p (pref perror :id))
228          (gui::alert-window 
229           :title "Notification" 
230           :message (format nil "~S needs the HyperSpec, and it does not appear to be available. Check the documentation in the Context-Menu-CM/ReadMe, and restart CCL." tool-name))))))))
231
232(setq *menu-manager* (make-instance 'context-menu-manager))
233
234
235
Note: See TracBrowser for help on using the repository browser.