[slime-cvs] CVS update: slime/swank.lisp

[Matthias Koeppe]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv6613

Modified Files:
	swank.lisp 
Log Message:
Move presentation menu protocol here from present.lisp.

Date: Sun Sep 18 16:34:32 2005
Author: mkoeppe

Index: slime/swank.lisp
diff -u slime/swank.lisp:1.337 slime/swank.lisp:1.338
--- slime/swank.lisp:1.337	Thu Sep 15 10:28:07 2005
+++ slime/swank.lisp	Sun Sep 18 16:34:31 2005
@@ -4208,6 +4208,117 @@
 
 (add-hook *pre-reply-hook* 'sync-indentation-to-emacs)
 
+
+;;;; Presentation menu protocol
+;;
+;; To define a menu for a type of object, define a method
+;; menu-choices-for-presentation on that object type.  This function
+;; should return a list of two element lists where the first element is
+;; the name of the menu action and the second is a function that will be
+;; called if the menu is chosen. The function will be called with 3
+;; arguments:
+;;
+;; choice: The string naming the action from above
+;;
+;; object: The object 
+;;
+;; id: The presentation id of the object
+;;
+;; You might want append (when (next-method-p) (call-next-method)) to
+;; pick up the Menu actions of superclasses.
+;;
+
+(defvar *presentation-active-menu* nil)
+
+(defun menu-choices-for-presentation-id (id)
+  (multiple-value-bind (ob presentp) (lookup-presented-object id)
+    (cond ((not presentp) 'not-present)
+	  (t
+	   (let ((menu-and-actions (menu-choices-for-presentation ob)))
+	     (setq *presentation-active-menu* (cons id menu-and-actions))
+	     (mapcar 'car menu-and-actions))))))
+
+(defun swank-ioify (thing)
+  (cond ((keywordp thing) thing)
+	((and (symbolp thing)(not (find #\: (symbol-name thing))))
+	 (intern (symbol-name thing) 'swank-io-package))
+	((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing))))
+	(t thing)))
+
+(defun execute-menu-choice-for-presentation-id (id count item)
+  (let ((ob (lookup-presented-object id)))
+    (assert (equal id (car *presentation-active-menu*)) () 
+	    "Bug: Execute menu call for id ~a  but menu has id ~a"
+	    id (car *presentation-active-menu*))
+    (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
+      (swank-ioify (funcall action item ob id)))))
+
+;; Default method
+(defmethod menu-choices-for-presentation (ob)
+  (declare (ignore ob))
+  nil)
+
+;; Pathname
+(defmethod menu-choices-for-presentation ((ob pathname))
+  (let* ((file-exists (ignore-errors (probe-file ob)))
+	 (lisp-type (make-pathname :type "lisp"))
+	 (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal))
+			   (let ((source (merge-pathnames lisp-type ob)))
+			     (and (ignore-errors (probe-file source))
+				  source))))
+	 (fasl-file (and file-exists 
+			 (equal (ignore-errors
+				  (namestring
+				   (truename
+				    (compile-file-pathname
+				     (merge-pathnames lisp-type ob)))))
+				(namestring (truename ob))))))
+    (remove nil 
+	    (list*
+	     (and (and file-exists (not fasl-file))
+		  (list "Edit this file" 
+			(lambda(choice object id) 
+			  (declare (ignore choice id))
+			  (ed-in-emacs (namestring (truename object)))
+			  nil)))
+	     (and file-exists
+		  (list "Dired containing directory"
+			(lambda (choice object id)
+			  (declare (ignore choice id))
+			  (ed-in-emacs (namestring 
+					(truename
+					 (merge-pathnames
+					  (make-pathname :name "" :type "") object))))
+			  nil)))
+	     (and fasl-file
+		  (list "Load this fasl file"
+			(lambda (choice object id)
+			  (declare (ignore choice id object)) 
+			  (load ob)
+			  nil)))
+	     (and fasl-file
+		  (list "Delete this fasl file"
+			(lambda (choice object id)
+			  (declare (ignore choice id object)) 
+			  (let ((nt (namestring (truename ob))))
+			    (when (y-or-n-p-in-emacs "Delete ~a? " nt)
+			      (delete-file nt)))
+			  nil)))
+	     (and source-file 
+		  (list "Edit lisp source file" 
+			(lambda (choice object id) 
+			  (declare (ignore choice id object)) 
+			  (ed-in-emacs (namestring (truename source-file)))
+			  nil)))
+	     (and source-file 
+		  (list "Load lisp source file" 
+			(lambda(choice object id) 
+			  (declare (ignore choice id object)) 
+			  (load source-file)
+			  nil)))
+	     (and (next-method-p) (call-next-method))))))
+  
+
 ;; Local Variables:
 ;; eval: (font-lock-add-keywords 'lisp-mode '(("(\\(defslimefun\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"  (1 font-lock-keyword-face) (2 font-lock-function-name-face))))
 ;; End: