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

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

Another new file, and mods to context-menu-cm.lisp.

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