API CHANGE: Removed the OBJECT arg from attribute-value

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

diff --git a/src/description.lisp b/src/description.lisp
dissimilarity index 90%
index 20362f8..ae5850c 100644 (file)
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -1,75 +1,101 @@
-(in-package :lisp-on-lines)
-
-(define-description description ())
-
-(defgeneric find-description-class (name &optional errorp)        
-  (:method ((name (eql t)) &optional errorp)
-    (declare (ignore errorp))
-    (find-class 'description t))
-  (:method ((name symbol) &optional errorp)
-    (or (find-class (defining-description name) errorp)
-       (find-description-class t)))
-  (:method ((description description) &optional errorp)
-    (declare (ignore errorp))
-    (class-of description)))
-
-(defun find-description (name)
-   (slot-value (find-description-class name) 'instance))
-
-(defun description-attributes (description)
-  (closer-mop:class-slots (find-description-class description)))
-
-(define-layered-function attributes (description))
-
-(define-layered-method attributes (description)
- (description-attributes description))
-                      
-;;;!-- TODO: This is a prime candidate for optimization
-(defun find-attribute (description attribute-name)
-  (find attribute-name (description-attributes description) :key #'attribute-name))
-
-(define-display ((description description))
-  (format *display* "~{~A~%~}" 
-         (mapcar 
-          (lambda (attribute)
-            (with-output-to-string (*display*)
-              (display-attribute attribute)))
-          (attributes description))))
-
-(define-layered-method description-of (object)
-  (find-description 't))                             
-
-(define-layered-method description-of ((symbol symbol))
-  (find-description 'symbol))
-
-(define-description symbol ()
-  ((identity :label "Symbol:")
-   (name 
-    :function #'symbol-name
-    :label "Name:")
-   (value 
-    :label "Value:" 
-    :function 
-    (lambda (symbol)
-      (if (boundp symbol)
-         (symbol-value symbol)
-         "<UNBOUND>")))
-   (package :function #'symbol-package
-           :label "Package:")
-   (function :label "Function:"
-    :function               
-    (lambda (symbol)
-     (if (fboundp symbol)
-        (symbol-function symbol)
-        "<UNBOUND>")))))
-
-
-                     
-  
-
-
-
-
-  
-  
-  
+(in-package :lisp-on-lines)
+
+(define-layered-function description-of (thing)
+  (:method (thing)
+    (find-description 't)))
+
+(defun description-print-name (description)
+  (description-class-name (class-of description)))
+
+(defun find-attribute (description attribute-name)
+  (when (slot-exists-p description attribute-name) 
+    (slot-value description attribute-name)))
+
+
+(defun description-attributes (description)
+  (let ((class (class-of description)))
+    (loop :for slot :in (class-slots class)
+       :if (and 
+               (not (eq 'described-object 
+                        (slot-definition-name slot))))
+       :collect (slot-definition-attribute-object slot))))
+
+
+
+(define-layered-function attributes (description)
+  (:method (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.
+(defmacro define-description (name &optional superdescriptions &body options)
+  (let ((description-name (defining-description name)))     
+    (destructuring-bind (&optional slots &rest options) options
+      (let ((description-layers (cdr (assoc :in-description options))))
+       (if description-layers
+           `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
+              ,@(loop 
+                   :for layer 
+                   :in description-layers
+                   :collect `(define-description 
+                                 ,name ,superdescriptions ,slots
+                                 ,@(acons 
+                                   :in-layer (defining-description layer)
+                                   (remove :in-description options :key #'car)))))
+           `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
+                                       ;  `(progn
+              (defclass ,description-name 
+                  ,(append (mapcar #'defining-description 
+                                   superdescriptions) 
+                           (unless (or (eq t name)    
+                                       (assoc :mixinp options))
+                             (list (defining-description t))))
+                ,(if slots slots '())
+                ,@options
+                ,@(unless (assoc :metaclass options)
+                          '((:metaclass standard-description-class))))
+              (initialize-descriptions)
+              (find-description ',name)))))))
+
+
+
+
+
+
+
+                             
+
+
+
+                     
+  
+
+
+
+
+  
+  
+