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

diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp
deleted file mode 100644
index efafa2e..0000000
--- a/src/defdisplay.lisp
+++ /dev/null
@@ -1,139 +0,0 @@
-(in-package :lisp-on-lines)
-
-(define-layered-function display-using-description (description object component)
-  (:method-combination wrapping-standard)
-  (:documentation
-   "Render the object in component, 
-    using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
-
-(defun make-display-function (component object
-			      &rest properties
-			      &key  (line #'line-in)
-			      &allow-other-keys)
-  "returns a function that expects a 3 argument function as its argument
-
-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 (((attributes description) 
-		   (or
-		    (attributes description)
-		    (list-attributes description))))
-	    ;; 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
-   "Displays OBJECT in COMPONENT."))
-
-(define-layered-method display ((component t) (object t)
-				&rest properties)
-  " 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."
-  (funcall (apply 'make-display-function component object properties)
-	   'display-using-description))
-
-;;;;; Macros
-
-(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)))
-	    
-	       ((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))))))
-      (apply function args)))
-
-(defmacro with-description ((description &rest properties) &body body)
-  `(funcall-with-description ,description (if ',(cdr properties)
-					       (list ,@properties)
-					       ,(car properties))
-    #'(lambda ()
-	,@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))))))
-
-(defmacro with-component ((component) &body body)
-  `(let ((self ,component))
-    (declare (ignorable self))
-    (flet ((display* (thing &rest args)
-	     (apply #'display ,component thing args))
-	   (display-attribute (attribute obj &rest
-					 props)
-	     (if props
-		 (funcall-with-description
-		  attribute props
-		  #'display-using-description attribute obj ,component)
-		 (display-using-description attribute obj ,component))))
-      (declare (ignorable #'display* #'display-attribute))
-      ,@body)))
-
-
-
-