source: trunk/source/contrib/foy/context-menu-cm/context-menu-cm.lisp @ 12735

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

Changed the appearance of the Default Tool submenu and added an alphabetical index to CL-Documentation-CM

File size: 10.4 KB
Line 
1;;;-*-Mode: LISP; Package: CONTEXT-MENU -*-
2
3;;; ----------------------------------------------------------------------------
4;;;
5;;;      context-menu-cm.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;;;      9/2/9   Changed the appearance of the Default Tool submenu.
20;;;      8/31/9  version 0.1b1
21;;;              First cut
22;;;              Numerous User Interface suggestions, Rainer Joswig
23;;;
24;;; ----------------------------------------------------------------------------
25
26(defpackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
27(in-package "CONTEXT-MENU")
28
29(export '(register-tool add-default-tool-menu update-tool-menu set-default-tool
30          tool-menu *hemlock-menu-dictionary* *tool-label-dictionary* *tool-doc-dictionary*
31          *tool-key-dictionary* *dark-turquoise-color* *light-gray-color* check-hyperspec-availability))
32
33(defparameter *menu-manager* nil "The context-menu-manager instance.")
34
35(defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
36(defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.28 0.28 1.0))
37(defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
38(defparameter *light-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
39
40(defparameter *hemlock-menu-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
41(#/setObject:forKey: *hemlock-menu-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
42(#/setObject:forKey: *hemlock-menu-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
43
44(defparameter *tool-label-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
45(#/setObject:forKey: *tool-label-dictionary* (#/systemFontOfSize: ns:ns-font (#/systemFontSize ns:ns-font)) #&NSFontAttributeName)
46(#/setObject:forKey: *tool-label-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
47
48(defparameter *tool-doc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
49(#/setObject:forKey: *tool-doc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
50(#/setObject:forKey: *tool-doc-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
51
52(defparameter *tool-key-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
53(#/setObject:forKey: *tool-key-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
54(#/setObject:forKey: *tool-key-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
55
56;;; ----------------------------------------------------------------------------
57;;;
58(defclass CONTEXT-MENU-MANAGER ()
59  ((tool-alist :initform nil :accessor tool-alist)
60   (default-tool :initform nil :accessor default-tool))
61  (:documentation "A class to manage Hemlock's contextual popup menu, supporting access by multiple tools."))
62
63(defmethod display-menu ((manager context-menu-manager) view event)
64  (when (default-tool manager)
65    (let ((entry (assoc (default-tool manager) (tool-alist manager) :test #'string-equal)))
66      (when entry 
67        (funcall (cdr entry) view event)))))
68
69(objc:defmethod #/menuForEvent: ((view gui::hemlock-text-view) (event :id))
70  (display-menu *menu-manager* view event))
71
72(defun register-tool (tool-name menu-function)
73  "Register the new tool with the menu-manager.  The last tool registered becomes the default tool."
74  (let ((entry (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car)))
75    (cond (entry
76           (gui::alert-window :title "Notification" :message (format nil "Re-registering ~S." tool-name))
77           (setf (tool-alist *menu-manager*) (delete tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))
78           (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*))))           
79          (t
80           (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*)))
81           (setf (tool-alist *menu-manager*)
82                 (sort (tool-alist *menu-manager*) #'string< :key #'car))
83           (set-default-tool tool-name)))))
84
85(defun set-default-tool (tool-name)
86  "Set the menu-manager's default tool.  Right-Click will display this tool's menu."
87  (let ((registered-name (car (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))))
88    (if registered-name
89      (setf (default-tool *menu-manager*) registered-name) ; keep the original capitalization
90      (gui::alert-window :title "Notification" :message (format nil "~S is not a registered tool.  It can't be set as default." tool-name)))))
91
92;;; ----------------------------------------------------------------------------
93;;;
94(defclass DEFAULT-TOOL-MENU-ITEM (ns:ns-menu-item)
95  ((name :accessor tool-name)) ; Lisp string
96  (:documentation "Support for the Tool submenu.")
97  (:metaclass ns:+ns-object))
98
99;;; ----------------------------------------------------------------------------
100;;;
101(defclass DEFAULT-TOOL-DOC-MENU-ITEM (ns:ns-menu-item)
102  ((filename :accessor tool-filename))
103  (:documentation "A menu-item to display the default tool's documentation.")
104  (:metaclass ns:+ns-object))
105
106;;; ----------------------------------------------------------------------------
107;;;
108(defclass DEFAULT-TOOL-MENU (ns:ns-menu)
109  ()
110  (:documentation "A submenu displaying all registered tools.")
111  (:metaclass ns:+ns-object))
112
113(objc:defmethod (#/hemlockDefaultToolAction: :void) ((m default-tool-menu) (sender :id))
114  (set-default-tool (tool-name sender)))
115
116(objc:defmethod (#/hemlockDefaultToolDocAction: :void) ((m default-tool-menu) (sender :id))
117  (display-doc (tool-filename sender)))
118
119(defun display-doc (path)
120  "Display the default tool's documentation."
121  (when (probe-file path)
122    (#/openFile:withApplication: (#/sharedWorkspace ns:ns-workspace) 
123                                 (ccl::%make-nsstring (namestring path))
124                                 (ccl::%make-nsstring "TextEdit"))))
125 
126(defmethod populate-menu ((menu default-tool-menu))
127  (dotimes (count (#/numberOfItems menu))
128    (#/removeItemAtIndex: menu 0))
129  (flet ((create-menu-item (name)
130           (let ((menu-item (make-instance 'default-tool-menu-item))
131                 (attributed-string (#/initWithString:attributes:
132                                     (#/alloc ns:ns-attributed-string) 
133                                     (ccl::%make-nsstring name)
134                                     *tool-label-dictionary*)))
135             (setf (tool-name menu-item) name) 
136             (#/setAttributedTitle: menu-item attributed-string)
137             (#/setAction: menu-item (ccl::@selector "hemlockDefaultToolAction:"))
138             (#/setTarget: menu-item  menu)
139             (if (string-equal name (default-tool *menu-manager*))
140               (#/setState: menu-item #$NSOnState)
141               (#/setState: menu-item #$NSOffState))
142             (#/addItem: menu menu-item))))
143    (dolist (entry (tool-alist *menu-manager*))
144      (create-menu-item (car entry)))))
145
146(defun add-default-tool-menu (menu &key doc-file)
147  "Add the default tool submenu and possibly a documentation menu-item to MENU."
148  (let ((default-item (make-instance ns:ns-menu-item))
149        (tool-menu (make-instance 'default-tool-menu)))
150    ;; Title is set by update method.
151    (#/setSubmenu: default-item tool-menu)
152    (#/insertItem:atIndex: menu default-item 0)
153    (cond (doc-file
154           (let ((doc-item (make-instance 'default-tool-doc-menu-item))
155                 (attributed-string (#/initWithString:attributes:
156                                     (#/alloc ns:ns-attributed-string) 
157                                     (ccl::%make-nsstring (format nil "     doc..." (default-tool *menu-manager*)))
158                                     *tool-doc-dictionary*)))
159             (#/setAttributedTitle: doc-item attributed-string)
160             (#/setAction: doc-item (ccl::@selector "hemlockDefaultToolDocAction:"))
161             (#/setTarget: doc-item  tool-menu)
162             (setf (tool-filename doc-item) doc-file)
163             (#/insertItem:atIndex: menu doc-item 1))
164          (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 2))
165          (t
166           (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 1)))
167    tool-menu))
168
169(defun update-tool-menu (menu default-menu &key sub-title)
170  "Update MENU's Tool submenu."
171  (let ((first-item (#/itemAtIndex: menu 0))
172        (attributed-string (#/initWithString:attributes:
173                            (#/alloc ns:ns-attributed-string) 
174                            (if sub-title
175                              (ccl::%make-nsstring (format nil "~S
176    (~A)" (default-tool *menu-manager*) sub-title))
177                              (ccl::%make-nsstring (format nil "~S" (default-tool *menu-manager*))))
178                            *tool-label-dictionary*)))
179    (#/setAttributedTitle: first-item attributed-string)
180    (populate-menu default-menu)))
181
182(let (checked-p)
183(defun check-hyperspec-availability (tool-name)
184  "Some tools require the HyperSpec."
185  (unless (or checked-p gui::*hyperspec-root-url*)
186    (rlet ((perror :id  +null-ptr+))
187      (let* ((map-url (make-instance 'ns:ns-url :with-string #@"Data/Map_Sym.txt" :relative-to-url (gui::hyperspec-root-url)))
188             ;; kludge alert:
189             (data (make-instance 'ns:ns-data
190                     :with-contents-of-url map-url
191                     :options 0
192                     :error perror)))
193        (declare (ignore data))
194        (setq checked-p t)
195        (unless (%null-ptr-p (pref perror :id))
196          (gui::alert-window 
197           :title "Notification" 
198           :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))))))))
199
200(setq *menu-manager* (make-instance 'context-menu-manager))
201
202(provide :context-menu-cm)
203
204
Note: See TracBrowser for help on using the repository browser.