CLIM mail archive
[Prev][Next][Index][Thread]

Reverse Inheritance of Accept Methods (was: for Gestures for commands more than 1 arg?)

    Date: Fri, 17 Sep 1993 14:56 EDT
    From: "Bruce R. Miller" <miller@cam.nist.gov>

    I have the following class hierarchy:

    OBJECT
      OBJECT-WITH-PARTS
	OBJECT-WITH-COMPONENTS
	  PACKAGE
	  MODULE
	MODULE-COLLECTION
	  CLASS
	  PACKAGE        
    [and a few others]

    The objects of real interest are: CLASS, PACKAGE, MODULE 
    (first 2 are shadowed in my package, of course)

The issue was to define accept methods for the `interesting' things 
CLASS, PACKAGE & MODULE  --- that's natural because they're mostly 
they're in hash tables ---  and somehow `inherit' these methods into 
accept methods for OBJECT-WITH-PARTS, OBJECT-WITH-COMPONENTS and
MODULE-COLLECTION --- which is needed because those are the natural
classes to translate into commands.

Well, I played around and came up with the following idea:

;;;********************************************************************************
;;; Nothing special here.
(define-presentation-type object ())

;;; This presents things as  "Class A" or "Package IMSLM"
(define-presentation-method present (thing (type object) stream (view textual-view) &key)
  (format stream "~:(~a~) ~a" (type-of thing)(name thing)))

;;; This determines the subclasses of a class which the user will recognize.
;;; In this example,  I consider all the leaves of the subclass tree to be `interesting' ones.
;;; eg (acceptable-subclasses (clos:find-class 'object-with-components) => (package module)
;;; Obviously, you could use a different criterion here.
(defun acceptable-subclasses (class)
  (let ((subs (clos:class-direct-subclasses class)))
    (if (null subs)
	(list (clos:class-name class))
	(loop for sub in subs appending (acceptable-subclasses sub)))))

;;; Now I can define an accept method to be inherited by all subclasses of OBJECT, 
;;; except for those with an explicitly defined accept method.
(define-presentation-method accept ((type object) stream (view textual-view) &key)
  ;; First accept the name of the type (one of the terminal cases)
  (let* ((leave-type (accept (cons 'member (acceptable-subclasses (clos:find-class type)))
			     :stream stream :prompt nil))
	 (char (read-gesture :stream stream)))	; eat the intervening space
    (unless (eql char #\space)
      (unread-gesture char :stream stream))
    ;; Now call accept on the specific type.
    (accept leave-type :stream stream :prompt nil :default nil)))

;;; Now, I've got to define accept methods for the terminal cases explicitly.
;;; There's a slight complication because of the type prefix.
;;; I add the appropriate prefix to the list of suggestions.
;;; If the prefix was indeed typed in, I just recurse and repeat it (this time without the prefix
;;; included).
;;;  So, accepting from the package hashtable will allow "package IMSLM" or just "IMSLM"
(defun accept-from-hashtable (stream table type-prefix)
  (let ((object (completing-from-suggestions
		  (stream :partial-completers '(#\space)
			  ;; Dont present the type-prefix as a possibility,
			  ;; and dont prefix the real objects either
			  :possibility-printer #'(lambda (poss type stream)
						   (when (second poss)
						     (with-output-as-presentation
						       (stream (second poss) type)
						       (write-string (first poss) stream)))))
		  (maphash #'(lambda (name ob)(suggest (string name) ob)) table)
		  (when type-prefix		; Allow the type prefix to be typed in.
		    (suggest type-prefix nil)))))
    (if (and type-prefix (eql object nil))	;  Yep, user typed in the type prefix.
	(let ((char (read-gesture :stream stream)))	; eat the intevening space
	  (unless (eql char #\space)
	    (unread-gesture char :stream stream))
	  (accept-from-hashtable stream table nil))	; and recurse (ie. 2nd try)
	object)))

;;; Now, the accept methods for package & class are trivial.
(define-presentation-method accept ((type package) stream (view textual-view) &key)
  (accept-from-hashtable stream *package-table* "Package"))

(define-presentation-method accept ((type class) stream (view textual-view) &key)
  (accept-from-hashtable stream *class-table* "Class"))

; Module is a bit tricky because the name (what a user would recognize) is ambigous.
; I may play with Bill's suggestion -- each module does in fact have a unique ID.

; Maybe I'll give module a present method which prints
; "Module <id> (<name>)"
; and then the accept method would check for the parenthesized name and ignore it.

; Hopefully, the user would still be intimidated enough not to try typing it in :>,
; but for most purposes he'd see the name and be comforted.
;;;********************************************************************************

So, in my best Ed McMahon impersonation (remember Ed McMahon?)
"So, Johny,  How Ugly Was It?"

  bruce
  miller@cam.nist.gov
References:
Main Index | Thread Index