-;;; an alist of model-class-name . attributes
-;;; should really be a hash-table.
-(defvar *attribute-map* (list))
-
-(defun find-or-create-attributes (class-name)
- "return an exisiting class attribute map or create one.
-
-A map is a cons of class-name . attributes.
-attributes is an alist keyed on the attribute name."
- (or (assoc class-name *attribute-map*)
- (progn
- (setf *attribute-map* (acons class-name (list (list)) *attribute-map*))
- (assoc class-name *attribute-map*))))
-
-(defgeneric find-class-attributes (class))
-
-(defmethod find-class-attributes ((model t))
- (find-or-create-attributes (class-name (class-of model))))
-
-(defmethod find-class-attributes ((model symbol))
- (find-or-create-attributes model))
-
-(defmethod clear-class-attributes ((model t))
- (setf (cdr (find-class-attributes model)) nil))
-
-(defmethod add-attribute ((model t) name def)
- (let ((map (find-class-attributes model)))
- (setf (cdr map) (acons name def (cdr map)))))
-
-(defmethod find-attribute ((model t) name)
- (assoc name (cdr (find-class-attributes model))))
-
-(defmethod (setf find-attribute) ((def list) (model t) name)
- (let ((attr (find-attribute model name)))
- (if attr
- (prog2
- (setf (cdr attr) def)
- attr)
- (prog2
- (add-attribute model name def)
- (find-attribute model name)))))
+;;;; * Occurences
+
+(defvar *occurence-map* (make-hash-table)
+ "Presentations are created 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 ()
+ ((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)))))
+
+
+;;;; * Attributes
+
+(define-layered-class
+ standard-attribute ()
+ ((name :layered-accessor attribute.name :initarg :name :initform "attribute")
+ (type :layered-accessor attribute.type :initarg :type :initform t :type symbol)
+ (plist :layered-accessor attribute.plist :initarg :plist :initform nil))
+ (: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) ))
+ `(progn
+
+ (define-layered-class
+ ;;;; TODO: naive way of making sure s-a is a superclass
+ ,name ,(or supers '(standard-attribute))
+ ,slots
+ #+ (or) ,@ (cdr args) )
+ (defmethod find-attribute-class-for-type ((type (eql ',type)))
+ ',name))))
+
+(defmethod print-object ((self standard-attribute) stream)
+ (print-unreadable-object (self stream :type t)
+ (with-slots (name type) self
+ (format stream "~A ~A" name type))))
+
+(define-layered-class
+ presentation-attribute (standard-attribute)
+ ()
+ (:documentation "Presentation Attributes are used to display objects
+using the attributes defined in an occurence. Presentation Attributes are always named using keywords."))
+
+(defun clear-attributes (name)
+ "removes all attributes from an occurance"
+ (clear-occurence (find-occurence name)))
+
+(defmethod find-attribute-class-for-type (type)
+ nil)