X-Git-Url: https://git.hcoop.net/clinton/lisp-on-lines.git/blobdiff_plain/a4e6154d961ff4b606aa534bd4e1570565cab351..e9c163726f466dee83a8dbe7d952f6aaff4345b6:/src/defdisplay.lisp diff --git a/src/defdisplay.lisp b/src/defdisplay.lisp index 9b4cb79..cb50cf5 100644 --- a/src/defdisplay.lisp +++ b/src/defdisplay.lisp @@ -2,6 +2,7 @@ (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.")) @@ -10,9 +11,33 @@ display-using-description (d o c) (<:as-html "default :" o)) -(defmethod find-layer-for-type (type) - type) +(defun make-display-function (component object + &rest properties + &key type (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." + + (lambda (function) + (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 + function description object component)))) + (error "no description for ~A" object))))) (define-layered-function display (component object &rest args) (:documentation @@ -20,36 +45,43 @@ (define-layered-method display ((component t) (object t) &rest properties - &key type + &key type (line #'line-in) &allow-other-keys) - "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method." - - (let* ((occurence (find-occurence object)) - (description (or (find-display-attribute - occurence - (setf type (or type (description.type occurence)))) - occurence))) - (if description - (dletf (((description.type occurence) type) - ((description.layers description) (append `(+ - - ;;find-layer-for-type is a - ;; backwards compat thing - ,(find-layer-for-type - type)) - (description.layers description))) - ((attributes description) (or - (attributes description) - (list-slots object)))) - (funcall-with-description - description properties - #'display-using-description description object component)) - (error "no description for ~A" object)))) + " 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." + + (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)))) ;;;;; Macros (defun funcall-with-description (description properties function &rest args) + (if description (dletf* (((description.type description) (or (getf properties :type) @@ -58,7 +90,7 @@ ((description.layers description) (append (description.layers description) (getf properties :layers))) - ((description.properties description) properties)) + ((description.properties description) (append (description.properties description) properties))) (funcall-with-layers (description.layers description) #'(lambda () @@ -68,8 +100,6 @@ (apply function args)))))) (apply function args))) - - (defmacro with-description ((description &rest properties) &body body) `(funcall-with-description ,description (if ',(cdr properties) (list ,@properties) @@ -77,18 +107,31 @@ #'(lambda () ,@body))) -(defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body 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)))))) + (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)) @@ -114,14 +157,18 @@ (when (member :in-layer qualifiers) (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers.")) (return - (destructuring-bind (description object &optional component) (car tail) + (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))