remove unused comment... this is why we don't comment.

[clinton/lisp-on-lines.git] / src / defdisplay.lisp

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index ae74b8c..36df62f 100644 (file)
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -1,7 +1,7 @@
 (in-package :lisp-on-lines)
 
 (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 +10,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 +57,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 +99,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 +106,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))