X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/fb04c0a8c71cd64e3a36cfed59a0224d44de2474..1d51a2eea8537084e9e681c297422047ae858989:/src/defdisplay.lisp

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
index cb50cf5..efafa2e 100644
--- a/src/defdisplay.lisp
+++ b/src/defdisplay.lisp
@@ -1,32 +1,26 @@
 (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."))
 
-(define-layered-method
-    display-using-description (d o c)
-    (<:as-html "default :" o))
-
 (defun make-display-function (component object
 			      &rest properties
-			      &key type (line #'line-in)
+			      &key  (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."
+The function argument (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))))
+	  (dletf (((attributes description) 
+		   (or
+		    (attributes description)
+		    (list-attributes description))))
 	    ;; apply the default line to the description
 	    (funcall-with-description
 	     description
@@ -44,9 +38,7 @@ The function (which is usually display-using-description) will be called with th
    "Displays OBJECT in COMPONENT."))
 
 (define-layered-method display ((component t) (object t)
-				&rest properties
-				&key type (line #'line-in)
-				&allow-other-keys)
+				&rest properties)
   " The default display dispatch method
 
   DISPLAY takes two required arguments, 
@@ -57,47 +49,41 @@ The function (which is usually display-using-description) will be called with th
   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))))
+  (funcall (apply 'make-display-function component object properties)
+	   'display-using-description))
 
 ;;;;; Macros
 
-
-(defun funcall-with-description (description properties function &rest args)
-  
+(defun funcall-with-layers (layers thunk)
+  (let ((context (current-layer-context)))
+    (loop :for (op layer) 
+       :on layers :by #'cddr
+       :do (setf context 
+		 (case op
+		   (+ (adjoin-layer layer context))
+		   (- (remove-layer layer context)))))
+    (funcall-with-layer-context context thunk)))
+		  
+
+(defun funcall-with-description (description properties function &rest args)  
   (if description
-      (dletf* (((description.type description) (or
-						(getf properties :type)
-						(description.type description)))
+      (dletf* (((description-type description) 
+		(or
+		 (getf properties :type)
+		 (description-type description)))
 	    
-	       ((description.layers description) (append 
-							 (description.layers description)
-							 (getf properties :layers)))
-	       ((description.properties description) (append (description.properties description) properties)))
+	       ((description-layers description) 
+		(append 
+		 (description-layers description)
+		 (getf properties :layers)))
+	       ((description-properties description) (append (description-properties description) properties)))
 	(funcall-with-layers 
-	 (description.layers description)
-	 #'(lambda ()
-	     (contextl::funcall-with-special-initargs
-	      (list (cons description properties))
-	      #'(lambda ()
-		  (apply function args))))))
+	 (description-layers description)
+	 (lambda ()
+	   (contextl::funcall-with-special-initargs
+	    (list (cons description properties))
+	    #'(lambda ()
+		(apply function args))))))
       (apply function args)))
 
 (defmacro with-description ((description &rest properties) &body body)
@@ -138,7 +124,8 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
     (declare (ignorable self))
     (flet ((display* (thing &rest args)
 	     (apply #'display ,component thing args))
-	   (display-attribute (attribute obj &optional props)
+	   (display-attribute (attribute obj &rest
+					 props)
 	     (if props
 		 (funcall-with-description
 		  attribute props
@@ -147,47 +134,6 @@ The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESC
       (declare (ignorable #'display* #'display-attribute))
       ,@body)))
 
-(defmacro defdisplay (&body body)
-  (loop with in-layerp = (eq (car body) :in-layer)
-	with layer = (if in-layerp (cadr body) 't)
-	for tail on (if in-layerp (cddr body) body)
-	until (listp (car tail))
-	collect (car tail) into qualifiers
-	finally
-	(when (member :in-layer qualifiers)
-	  (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
-	(return
-	  (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))
-		      description)
-		     (t
-		      (setf d description)
-		      (setf standard-description-p t)
-		      `(,d description)))
-		   ,object
-		   ,(cond
-		     ((null component)
-		      `(,c component))
-		     ((listp component)
-		      (setf c (car component))
-		      component)
-		     (t
-		      (setf c component)
-		      `(,c component))))
-		  (with-component (,c)  
-			 ,@(cdr tail)))))))))
+