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

Re: Reverse Inheritance of Accept Methods

	From: "Bruce R. Miller" <miller@cam.nist.gov>
	Subject: Reverse Inheritance of Accept Methods (was: for Gestures for commands more than 1 arg?)


	[deleted]

	I have the following class hierarchy:

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

	The quesiton is: How do I write an accept method for (eg)
	OBJECT-WITH-COMPONENTS without throwing modularity out the window?   
	Ie, OBJECT-WITH-COMPONENTS ultimately amounts to (OR PACKAGE MODULE) 
	---  but I'm not supposed to know that!

	My print method was inspired by the parser for Genera Namespace objects.
	I could do the same here:  read a token (one of package, module)
	and then invoke some generic on that token that reads a class-name,
	package-name or whatever.  But I've _still_ got to get a list of which
	leaf classes are appropriate.  I suppose I could get a list of
	subclasses of a class?

	Alternatively, I suppose I could write an accept method that did
	something like

	(defmethod do-accept (class stream ...)
	  (loop for sub in (clos:class-direct-subclasses clos-class)
		thereis (do-accept sub stream ...)))

	(defmethod do-accept ('class stream ...)
	  <from hashtable>)

Looping over all subclasses would not do the intended thing.
Instead, you'll have to read in first the name of the class 
(out of the list) and then read the object of that class.
ie. like:

(define accept (..)
  (let ((class (accept 'class)))
        (object (accept `(object-of ,class)
 ..))

Now, let's waste some net bandwidth:
I've written some naive code that does what was outlined above.
Hopefully, it's also the kind of thing you need (ie. if 
I understood your question correctly).

Markus Fischer

PS: It was really fun to write some clean code again,
being usually busy in hacking up some crazed system.

;;; -*- Mode: LISP; Package: CLIM-USER -*-

;;; Tested on CLIM 1.1 Genera 8.1, but should run on all other CL+CLOS+CLIM platforms, too.

#-Genera
(in-package :clim-user)

(shadow 'clos::package)

;;; The class hierarchy
;;; --------------------------------------------------------------------------------

(defclass namespace-object ()
    ((name :initarg :name)
     (properties :initarg :properties)))

(defclass module (namespace-object)
    ())

(defclass package (namespace-object)
    ())

;;; The storing mechanism
;;; -------------------------------------------------------------------------------- 

(defvar *namespace-objects* (make-hash-table))

(defmacro namespace-objects (class-name)
  `(gethash ,class-name *namespace-objects*))

(defmacro namespace-object (class-name object-name)
  `(gethash ,object-name (namespace-objects ,class-name)))

;; The name is double-stored (in object and hash-table) in order to allow fast retrieval.

;;; Some initial namespace classes and objects
;;; --------------------------------------------------------------------------------

(setf (namespace-objects 'module) (make-hash-table))
(setf (namespace-objects 'package) (make-hash-table))

(setf (namespace-object 'module 'nikita) 
      (make-instance 'module
		     :name 'nikita 
		     :properties '(liker me non-liker all-the-others)))

(setf (namespace-object 'package 'prospero) 
      (make-instance 'package
		     :name 'prospero
		     :properties '(liker all-the-others non-liker me)))

;;; The CLIM interface
;;; --------------------------------------------------------------------------------

(define-presentation-method present (object (type namespace-object) stream 
					    (view textual-view) &key)
  (format stream "~A ~A" type (slot-value object 'name)))

(define-presentation-method accept ((type namespace-object) stream 
				    (view textual-view) &key)
  (let* ((class-name (accept `(member ,@(map 'list #'clos:class-name
					     ;; this could also be "class-subclasses",
					     ;; but that's not CLOS-built-in
					     (clos:class-direct-subclasses 
					       (clos:find-class 'namespace-object))))
			     :prompt NIL
			     :stream stream))
	 (object-name (accept `(token-or-type ,(let ((list NIL))
						 (maphash #'(lambda (key val)
							      (declare (ignore val))
							      (push key list))
							  (namespace-objects class-name))
						 (nreverse list))
					      symbol)
			      :prompt NIL
			      :stream stream)))
    (or (namespace-object class-name object-name)
	(setf (namespace-object class-name object-name) 
	      (make-instance class-name :name object-name :properties '(might-be useful))))))

;;; EOF
Follow-Ups:
Main Index | Thread Index