+(define-layered-class description ()
+ ((description-type
+ :initarg :type
+ :accessor description.type
+ :initform 'viewer
+ :special t)
+ (description-layers
+ :initarg :layers
+ :accessor description.layers
+ :initform nil
+ :special t)
+ (description-properties
+ :accessor description.properties
+ :initform nil
+ :special t)
+ (description-attributes
+ :accessor attributes
+ :initarg :attributes
+ :initform nil
+ :special t)))
+
+(defmethod print-object ((self description) stream)
+ (print-unreadable-object (self stream :type t)
+ (with-slots (description-type) self
+ (format t "~A" description-type))))
+
+;;;; * Occurences
+
+(defvar *occurence-map* (make-hash-table)
+ "a display is generated by associating an 'occurence'
+with an instance of a class. This is usually keyed off class-name,
+although an arbitrary occurence can be used with an arbitrary class.")
+
+(define-layered-class
+ standard-occurence (description)
+ ((attribute-map :accessor attribute-map :initform (make-hash-table)))
+ (:documentation
+ "an occurence holds the attributes like a class holds slot-definitions.
+Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects."))
+
+(defun find-or-create-occurence (name)
+ "Returns the occurence associated with this name."
+ (let ((occurence (gethash name *occurence-map*)))
+ (if occurence
+ occurence
+ (let ((new-occurence (make-instance 'standard-occurence)))
+ (setf (gethash name *occurence-map*) new-occurence)
+ new-occurence))))
+
+(defun clear-occurence (occurence)
+ "removes all attributes from the occurence"
+ (setf (attribute-map occurence) (make-hash-table)))
+
+(defgeneric find-occurence (name)
+ (:method (thing)
+ nil)
+ (:method ((name symbol))
+ (find-or-create-occurence name))
+ (:method ((instance standard-object))
+ (find-or-create-occurence (class-name (class-of instance)))))
+
+
+(define-layered-class
+ attribute (description)
+ ((name :layered-accessor attribute.name
+ :initarg :name
+ :initform (gensym "ATTRIBUTE-")
+ :special t)
+ (occurence :accessor occurence :initarg :occurence :initform nil)
+ (label :initarg :label :accessor label :initform nil :special t)))
+
+;;;; * Attributes
+(defmethod print-object ((self attribute) stream)
+ (print-unreadable-object (self stream :type t)
+ (with-slots (name description-type) self
+ (format stream "~A ~A" description-type name))))
+
+(define-layered-class
+ standard-attribute (attribute)
+ ((setter :accessor setter :initarg :setter :special t :initform nil)
+ (getter :accessor getter :initarg :getter :special t :initform nil)
+ (slot-name :accessor slot-name :initarg :slot-name :special t)
+ (id :accessor id :initarg :id :special t :initform (random-string)))
+ (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc."))
+
+(defmacro defattribute (name supers slots &rest args)
+ (let ((type (or (second (assoc :type-name args)) name))
+ (layer (or (second (assoc :in-layer args)) nil))
+ (properties (cdr (assoc :default-properties args)))
+ (cargs (remove-if #'(lambda (key)
+ (or (eql key :type-name)
+ (eql key :default-properties)
+ (eql key :default-initargs)
+ (eql key :in-layer)))
+ args
+ :key #'car)))
+
+ `(progn
+ (define-layered-class
+ ;;;; TODO: fix the naive way of making sure s-a is a superclass
+ ;;;; Need some MOPey goodness.
+ ,name ,@ (when layer `(:in-layer ,layer)),(or supers '(standard-attribute))
+ ,(append slots (properties-as-slots properties))
+ #+ (or) ,@ (cdr cargs)
+ ,@cargs
+ (:default-initargs :properties (list ,@properties)
+ ,@ (cdr (assoc :default-initargs args))))