remove unused comment... this is why we don't comment.
[clinton/lisp-on-lines.git] / src / defdisplay.lisp
index 9b4cb79..36df62f 100644 (file)
@@ -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."))
     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
 
 (define-layered-method display ((component t) (object t)
                                &rest properties
-                               &key type
+                               &key type (line #'line-in)
                                &allow-other-keys)
-    "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)))
-      (if description
-         (dletf (((description.type occurence) type)
-                 ((description.layers description) (append `(+
-
-                                                             ;;find-layer-for-type is a
-                                                             ;; backwards compat thing
-                                                          ,(find-layer-for-type
-                                                            type))
-                                                        (description.layers description)))
-                 ((attributes description) (or
-                                            (attributes description)
-                                            (list-slots object))))
-           (funcall-with-description
-            description properties
-            #'display-using-description description object component))
-         (error "no description for ~A" object))))
+  " The default display dispatch method
+
+  DISPLAY takes two required arguments, 
+  COMPONENT : The component to display FROM (not neccesarily 'in')
+  OBJECT : The 'thing' we want to display... in this case it's the component
+
+  DISPLAY also takes keywords arguments which modify the DESCRIPTION,
+  that is to say the parameters that come together to create the output.
+
+The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
+
+  (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
+               #'display-using-description description object component))))
+       (error "no description for ~A" object))))
 
 ;;;;; Macros
 
 
 (defun funcall-with-description (description properties function &rest args)
+  
   (if description
       (dletf* (((description.type description) (or
                                                (getf properties :type)
@@ -58,7 +89,7 @@
               ((description.layers description) (append 
                                                         (description.layers description)
                                                         (getf properties :layers)))
-              ((description.properties description) properties))
+              ((description.properties description) (append (description.properties description) properties)))
        (funcall-with-layers 
         (description.layers description)
         #'(lambda ()
@@ -68,8 +99,6 @@
                  (apply function args))))))
       (apply function args)))
 
-
-
 (defmacro with-description ((description &rest properties) &body body)
   `(funcall-with-description ,description (if ',(cdr properties)
                                               (list ,@properties)
     #'(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))
        (when (member :in-layer qualifiers)
          (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
        (return
-         (destructuring-bind (description object &optional component) (car tail) 
+         (destructuring-bind (description &optional object component) (car tail) 
            (with-unique-names (d c)
              (let (standard-description-p)
                `(define-layered-method
                  display-using-description
                  :in-layer ,layer
                  ,@qualifiers
-               
+
+                 ,@(unless object
+                           (setf object description)
+                           (setf description d)
+                           nil)
                  (,(cond
                     ((listp description)
                      (setf d (car description))