add more files for new description code

darcs-hash:20091220225943-39164-fe3b1bdd607547af7c0dc5e736e01f7cc3775ad7.gz

diff --git a/src/mao/display/define-description-compat.lisp b/src/mao/display/define-description-compat.lisp
new file mode 100644 (file)
index 0000000..5ada284
--- /dev/null
+++ b/src/mao/display/define-description-compat.lisp
@@ -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))))

diff --git a/src/mao/display/display-attribute.lisp b/src/mao/display/display-attribute.lisp
new file mode 100644 (file)
index 0000000..e9ea969
--- /dev/null
+++ b/src/mao/display/display-attribute.lisp
@@ -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!")))
\ No newline at end of file

diff --git a/src/mao/display/display-description.lisp b/src/mao/display/display-description.lisp
new file mode 100644 (file)
index 0000000..000c548
--- /dev/null
+++ b/src/mao/display/display-description.lisp
@@ -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))))
\ No newline at end of file