X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/0386c736fe19db9f72a9d12728f5707cf570778f..e9c163726f466dee83a8dbe7d952f6aaff4345b6:/src/defdisplay.lisp

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index ae74b8c..cb50cf5 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -2,6 +2,7 @@
 
 (define-layered-function display-using-description (description object component)
 ;  (:argument-precedence-order )
+  (:method-combination wrapping-standard)
   (:documentation
    "Render the object in component, 
     using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
@@ -10,9 +11,33 @@
     display-using-description (d o c)
     (<:as-html "default :" o))
 
-(defmethod find-layer-for-type (type)
-  type)
-
+(defun make-display-function (component object
+			      &rest properties
+			      &key type (line #'line-in)
+			      &allow-other-keys)
+  "returns a function that expects a 3 argument function as its argument
+
+The function (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
+
+  (lambda (function)
+    (let* ((description (find-occurence object)))
+
+      (if description
+	  (dletf (((description.type description) type)
+		  ((attributes description) (or
+					     (attributes description)
+					     (list-slots object))))
+	    ;; apply the default line to the description
+	    (funcall-with-description
+	     description
+	     (funcall line object)
+	     ;; apply the passed in arguments and call display-using-description
+	     #'(lambda ()		 
+		 (funcall-with-description
+		  description
+		  properties
+		  function description object component))))
+	  (error "no description for ~A" object)))))
 
 (define-layered-function display (component object &rest args)
   (:documentation
@@ -33,13 +58,10 @@
 
 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
 
-  (let* ((occurence (find-occurence object))
-	 (description (or (find-display-attribute
-			   occurence
-			   (setf type (or type (description.type occurence))))
-			  occurence)))
+  (let* ((description (find-occurence object)))
+
     (if description
-	(dletf (((description.type occurence) type)
+	(dletf (((description.type description) type)
 		((attributes description) (or
 					   (attributes description)
 					   (list-slots object))))
@@ -78,8 +100,6 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
 		  (apply function args))))))
       (apply function args)))
 
-
-
 (defmacro with-description ((description &rest properties) &body body)
   `(funcall-with-description ,description (if ',(cdr properties)
 					       (list ,@properties)
@@ -87,18 +107,31 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
     #'(lambda ()
 	,@body)))
 
-(defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body body)
+(define-layered-function find-do-attributes (desc))
+
+(define-layered-method find-do-attributes ((description description))
+
+  (loop
+     :for att
+     :in (attributes description)
+     :collect (let ((default (find (car (ensure-list att))
+				   (default-attributes description)
+				   :key #'car)))
+		(or default att))))
+
+(defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
   (with-unique-names (att properties type)
     `(dolist* (,att  ,attributes)
-      (let* ((,att (ensure-list ,att))
-                (,properties (rest ,att))
-                (,type (getf ,properties :type))
-                (,var (let ((a (find-attribute ,description (first ,att))))
-			(if ,type
-			    (apply #'make-attribute :name (first ,att) :type ,type ,properties)
-			    (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
-	(funcall-with-description ,var ,properties
-	  #'(lambda () ,@body))))))
+       (let* ((,att (ensure-list ,att))
+	      (,properties (rest ,att))
+	      (,type (getf ,properties :type))
+	      (,var (let ((a (find-attribute ,description (first ,att))))
+		      (if ,type
+			  (apply #'make-attribute :name (first ,att) :type ,type ,properties)
+			  (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
+	 (funcall-with-description ,var ,properties
+				   #'(lambda ()
+				       ,@body))))))
 
 (defmacro with-component ((component) &body body)
   `(let ((self ,component))