Permalink
Browse files

add more files for new description code

darcs-hash:20091220225943-39164-fe3b1bdd607547af7c0dc5e736e01f7cc3775ad7.gz
  • Loading branch information...
1 parent 6d0aa5e commit a3006fa0392b8bc1464e9917b8b820554b8f4a35 @drewc committed Dec 20, 2009
@@ -0,0 +1,76 @@
+(in-package :lol)
+
+(defclass define-description-class (display-description-class)
+ ())
+
+(define-layered-class define-description-attribute (display-attribute) ())
+
+(define-layered-method attribute-function ((attribute define-description-attribute))
+ (call-next-method)
+)
+
+(defgeneric eval-property-initarg (att initarg)
+ (:method ((attribute standard-attribute) initarg)
+ nil)
+ (:method ((attribute standard-attribute) (initarg (eql :function)))
+ t)
+ (:method ((attribute standard-attribute) (initarg (eql :value)))
+ t))
+
+(defun prepare-initargs (att args)
+ (loop
+ :for (key arg)
+ :on args :by #'cddr
+ :nconc (list key
+ (if (eval-property-initarg att key)
+ (eval arg)
+ arg))))
+
+(defmethod initialize-attribute-for-description :around (description (attribute define-description-attribute) layer &rest args)
+ (apply #'call-next-method description attribute layer (prepare-initargs attribute args)))
+
+(defmethod description-class-attribute-class ((class display-description-class))
+ 'define-description-attribute)
+
+(defmacro define-description (name &optional superdescriptions &body options)
+ (destructuring-bind (&optional slots &rest options) options
+ `(let ((%dn ',name))
+ (declare (special %dn))
+ (defdescription ,name ,superdescriptions
+ ,(if slots slots '())
+ ,@options
+ ,@(unless (assoc :metaclass options)
+ '((:metaclass define-description-class)))))))
+
+(defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '()))
+ (declare (dynamic-extent initargs)
+ (special %dn))
+ (prog1
+ (if (or (and (boundp '%dn) (eql %dn t))
+ (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (class-of (find-description 't))))
+ initargs))))
+
+
+(defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs)
+ (special %dn))
+; (warn "CLASS ~A ARGS ~A:" class initargs)
+ (prog1
+ (if (or (not direct-superclasses-p)
+ (and (boundp '%dn) (eql %dn t))
+ (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (class-of (find-description 't))))
+ initargs))))
@@ -0,0 +1,34 @@
+(in-package :lisp-on-lines)
+
+(define-layered-class display-attribute (standard-attribute)
+ ((label
+ :layered-accessor attribute-label
+ :initarg :label
+ :initform nil
+ :layered t
+ :special t)
+ (label-formatter
+ :layered-accessor attribute-label-formatter
+ :initarg :label-formatter
+ :initform nil
+ :layered t
+ :special t)
+ (value-formatter
+ :layered-accessor attribute-value-formatter
+ :initarg :value-formatter
+ :initform nil
+ :layered t
+ :special t)
+
+))
+
+(define-layered-method attribute-label-formatter :around (attribute)
+ (or (slot-value attribute 'label-formatter)
+ (attribute-value (find-attribute (attribute-description attribute) 'label-formatter))
+ (error "No Formatter .. fool!")))
+
+(define-layered-method attribute-value-formatter :around (attribute)
+
+ (or (slot-value attribute 'value-formatter)
+ (attribute-value (find-attribute (attribute-description attribute) 'value-formatter))
+ (error "No Formatter .. fool!")))
@@ -0,0 +1,59 @@
+(in-package :lisp-on-lines)
+
+(defclass display-description-class (standard-description-class)
+ ())
+
+(defmethod description-class-attribute-class ((class display-description-class))
+ 'display-attribute)
+
+(defun label-for-object (object)
+ (format nil "~@(~A~)"
+ (substitute #\Space #\-
+ (symbol-name
+ (class-name (class-of
+ object))))))
+#+nil(defdescription t ()
+ ((label :label nil
+ :function label-for-object)
+ (identity :label nil :function identity)
+ (type :label "Type" :function type-of)
+ (class :label "Class" :function class-of)
+ (attribute-delimiter :label "Attribute Delimiter"
+ :value "~%"
+ :activep nil
+ :keyword :delimter)
+
+ (label-formatter :value princ-to-string
+ :activep nil)
+ (value-formatter :value princ-to-string
+ :activep nil))
+ (:metaclass standard-description-class))
+
+#+nil(defmethod initialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '()))
+ (declare (dynamic-extent initargs))
+ (prog1
+ (if (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t)))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (class-of (find-description 't))))
+ initargs))))
+
+
+#+nil(defmethod reinitialize-instance :around ((class display-description-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+ (declare (dynamic-extent initargs))
+; (warn "CLASS ~A ARGS ~A:" class initargs)
+ (prog1
+ (if (or (not direct-superclasses-p)
+ (loop for direct-superclass in direct-superclasses
+ thereis (ignore-errors (subtypep direct-superclass (class-of (find-description t))))))
+ (call-next-method)
+ (apply #'call-next-method
+ class
+ :direct-superclasses
+ (append direct-superclasses
+ (list (class-of (find-description 't))))
+ initargs))))

0 comments on commit a3006fa

Please sign in to comment.