From: drewc <drewc@tech.coop>
Date: Sun, 20 Dec 2009 22:59:43 +0000 (-0800)
Subject: add more files for new description code
X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/commitdiff_plain/a3006fa0392b8bc1464e9917b8b820554b8f4a35

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
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
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
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