[Openmcl-cvs-notifications] r14247 - /trunk/source/cocoa-ide/cocoa-editor.lisp

[rme at clozure.com]

Author: rme
Date: Fri Sep 10 15:41:33 2010
New Revision: 14247

Log:
Add some contextual menu commands to Hemlock editor views.

There are two commands at the moment:
  * If the selection designates a file name (as determined by the
    the function gui::pathname-for-namestring-fragment), then the
    menu will contain an item that will open the said file.
  * If the selection looks like a symbol, there will be a menu item
    that will inspect the symbol.

This could be elaborated substantially, but it's a stake in the
ground, so to speak.

Modified:
    trunk/source/cocoa-ide/cocoa-editor.lisp

Modified: trunk/source/cocoa-ide/cocoa-editor.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-editor.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-editor.lisp Fri Sep 10 15:41:33 2010
@@ -1791,12 +1791,62 @@
 (objc:defmethod #/defaultMenu ((class +hemlock-text-view))
   (text-view-context-menu))
 =

+(defun pathname-for-namestring-fragment (string)
+  "Return a pathname that STRING might designate."
+  ;; We could get fancy here, but for now just be stupid.
+  (let ((pathname (ignore-errors (probe-file string))))
+    (if (and (pathnamep pathname)
+             (not (directory-pathname-p pathname)))
+      pathname)))
+
+;;; If we get here, we've already checked that the selection represents
+;;; a valid pathname.
+(objc:defmethod (#/openSelection: :void) ((self hemlock-text-view) sender)
+  (declare (ignore sender))
+  (let* ((text (#/string self))
+         (selection (#/substringWithRange: text (#/selectedRange self)))
+         (pathname (pathname-for-namestring-fragment
+                    (lisp-string-from-nsstring selection))))
+    (ed pathname)))
+
+;;; If we get here, we've already checked that the selection represents
+;;; a valid symbol name.
+(objc:defmethod (#/inspectSelection: :void) ((self hemlock-text-view) send=
er)
+  (declare (ignore sender))
+  (let* ((text (#/string self))
+         (selection (#/substringWithRange: text (#/selectedRange self)))
+         (symbol-name (string-upcase (lisp-string-from-nsstring selection)=
)))
+    (inspect (find-symbol symbol-name))))
+
 ;;; If we don't override this, NSTextView will start adding Google/
 ;;; Spotlight search options and dictionary lookup when a selection
 ;;; is active.
 (objc:defmethod #/menuForEvent: ((self hemlock-text-view) event)
   (declare (ignore event))
-  (#/menu self))
+  (let* ((text (#/string self))
+	 (selection (#/substringWithRange: text (#/selectedRange self)))
+	 (s (lisp-string-from-nsstring selection))
+         (menu (if (> (length s) 0)
+                 (#/copy (#/menu self))
+                 (#/retain (#/menu self)))))
+    (when (find-symbol (string-upcase s))
+      (let* ((title (#/stringByAppendingString: #@"Inspect " selection))
+             (item (make-instance 'ns:ns-menu-item :with-title title
+                     :action (@selector #/inspectSelection:)
+                     :key-equivalent #@"")))
+        (#/setTarget: item self)
+        (#/insertItem:atIndex: menu item 0)
+        (#/release item)))
+    (when (pathname-for-namestring-fragment s)
+      (let* ((title (#/stringByAppendingString: #@"Open " selection))
+             (item (make-instance 'ns:ns-menu-item :with-title title
+                     :action (@selector #/openSelection:)
+                     :key-equivalent #@"")))
+        (#/setTarget: item self)
+        (#/insertItem:atIndex: menu item 0)
+        (#/release item)))
+
+    (#/autorelease menu)))
 =

 (defun make-scrolling-text-view-for-textstorage (textstorage x y width hei=
ght tracks-width color style)
   (let* ((scrollview (#/autorelease