X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/4867c86f7dce578458c4130d9a8cfbf1041f7c4a..2548f0540da69973512f1827b2bfd2360470bb27:/src/description.lisp

diff --git a/src/description.lisp b/src/description.lisp
dissimilarity index 91%
index 4195bb2..d373ace 100644
--- a/src/description.lisp
+++ b/src/description.lisp
@@ -1,65 +1,159 @@
-(in-package :lisp-on-lines)
-
-(define-description 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)
+
+(defvar *object* nil)
+(defvar *description*)
+
+(define-layered-function description-of (thing)
+  (:method (thing)
+    (find-description 't)))
+
+(defun description-print-name (description)
+  (description-class-name (class-of description)))
+
+(defun description-attributes (description)
+  (description-class-attributes (class-of description)))
+
+(defun description-current-attributes (description)
+  	  (remove-if-not 
+	   (lambda (attribute)
+	     (and 		     
+	      (some #'layer-active-p 
+			(mapcar #'find-layer 
+				(slot-definition-layers 
+				 (attribute-effective-attribute-definition attribute))))))
+	   (description-attributes description)))
+
+(defun description-active-attributes (description)
+  	  (remove-if-not 
+	   #'attribute-active-p
+	   (description-attributes description)))
+
+(defun find-attribute (description attribute-name &optional (errorp t))
+  (or (find attribute-name (description-attributes description)
+	    :key #'attribute-name)
+      (when errorp (error "No attribute named ~A found in ~A" attribute-name 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)))
+
+(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)
+    (let* ((active-attributes 
+	    (find-attribute description 'active-attributes))
+	   (attributes (when active-attributes
+			 (ignore-errors (attribute-value active-attributes)))))
+      (remove-if-not 
+       (lambda (attribute)
+	 (and attribute
+	      (attribute-active-p attribute)		     
+	      (some #'layer-active-p 
+		    (mapcar #'find-layer 
+			    (slot-definition-layers 
+			     (attribute-effective-attribute-definition attribute))))))
+       (if attributes
+	   (mapcar (lambda (spec)		    
+		     (find-attribute 
+		      description
+		      (if (listp spec)
+			  (car spec)
+			  spec)))
+		   attributes)
+	   (description-attributes description))))))
+	  
+
+(defun funcall-with-described-object (function object description &rest args)
+  (setf description (or description (description-of object)))
+  (let ((*description* description)
+	(*object*  object))
+    (dletf (((described-object *description*) object))
+	(funcall-with-layer-context
+	 (modify-layer-context 
+	  (if (standard-description-p *description*)
+	      (adjoin-layer *description* (current-layer-context))
+	      (current-layer-context))
+	  :activate (description-active-descriptions *description*)
+	  :deactivate (description-inactive-descriptions *description*))
+	 (lambda () (contextl::funcall-with-special-initargs  
+		     (loop 
+			:for (key val) :on args :by #'cddr
+			:collect (list (find key (description-attributes *description*) 
+					     :key #'attribute-keyword)
+				       :value val))
+		     (lambda ()
+		       (contextl::funcall-with-special-initargs  
+			(let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))	
+			  (when attribute
+			    (loop for spec in (attribute-value attribute)
+			       if (listp spec)
+			       collect (cons (or 
+					      (find-attribute *description* (car spec))
+					      (error "No attribute matching ~A" (car spec)))
+					     (cdr spec)))))
+			function))))))))
+
+
+(defmacro with-described-object ((object description &rest args)
+				 &body body)
+    `(funcall-with-described-object 
+      (lambda () ,@body)
+      ,object
+      ,description
+      ,@args))
+		   
+(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)))))))
+
+
+
+
+
+
+
+			      
+
+
+
+		      
+  
+
+
+
+
+  
+  
+