added ROFL test cases + extra formatting hooks for attributes

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

diff --git a/src/description.lisp b/src/description.lisp
index c06a6f4..710771f 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -7,32 +7,51 @@
 (defun description-print-name (description)
   (description-class-name (class-of description)))
 
-(defun find-attribute (description attribute-name)
-  (slot-value description attribute-name))
+(defun description-attributes (description)
+  (description-class-attributes (class-of description)))
 
+(defun find-attribute (description attribute-name)
+  (find attribute-name (description-attributes description)
+       :key #'attribute-name))
 
-(defun description-attributes (description)
-  (mapcar (curry
-          #'slot-value-using-class 
-          (class-of 'description)
-          description) 
-         (class-slots (class-of description))))
+(define-layered-function description-active-descriptions (description)
+  (:method ((description standard-description-object))
+    (attribute-value (find-attribute description 'active-descriptions)))
+  (:method ((description attribute))
+    (attribute-active-descriptions description)))
 
-(defvar *display-attributes* nil)
-(defun attribute-active-p (attribute)
-  (or (null *display-attributes*)
-      (find (attribute-name attribute) *display-attributes*)))
+(define-layered-function description-inactive-descriptions (description)
+  (:method ((description standard-description-object))
+    (attribute-value (find-attribute description 'inactive-descriptions)))
+  (:method ((description attribute))
+    (attribute-inactive-descriptions description)))
 
 (define-layered-function attributes (description)
   (:method (description)
-    (remove-if-not 
-     (lambda (attribute)
-       (and (attribute-active-p attribute)
-           (some #'layer-active-p 
-            (mapcar #'find-layer 
-                    (slot-definition-layers 
-                     (attribute-effective-attribute-definition attribute))))))
-     (description-attributes description))))
+    (let* ((active-attributes 
+           (find-attribute description 'active-attributes))
+          (attributes (when active-attributes
+            (attribute-value active-attributes))))
+      (if attributes
+         (mapcar (lambda (spec)                    
+                   (find-attribute 
+                    description
+                    (if (listp spec)
+                        (car spec)
+                        spec)))
+                 attributes)
+         (remove-if-not 
+          (lambda (attribute)
+            (and (attribute-active-p attribute)                     
+                 (some #'layer-active-p 
+                       (mapcar #'find-layer 
+                               (slot-definition-layers 
+                                (attribute-effective-attribute-definition attribute))))))
+          (description-attributes description))))))
+         
+
+
+  
 
   
 ;;; A handy macro.