src/defdisplay.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (define-layered-function display-using-description (description object component)
   4 ;  (:argument-precedence-order )
   5   (:documentation
   6    "Render the object in component,
   7     using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
   8
   9 (define-layered-method
  10     display-using-description (d o c)
  11     (<:as-html "default :" o))
  12
  13 (defmethod find-layer-for-type (type)
  14   type)
  15
  16
  17 (define-layered-function display (component object &rest args)
  18   (:documentation
  19    "Displays OBJECT in COMPONENT."))
  20
  21 (define-layered-method display ((component t) (object t)
  22                                 &rest properties
  23                                 &key type
  24                                 &allow-other-keys)
  25     "The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
  26
  27     (let* ((occurence (find-occurence object))
  28            (description (or (find-display-attribute
  29                              occurence
  30                              (setf type (or type (description.type occurence))))
  31                            occurence)))
  32       (if description
  33           (dletf (((description.type occurence) type)
  34                   ((description.layers description) (append `(+
  35
  36                                                               ;;find-layer-for-type is a
  37                                                               ;; backwards compat thing
  38                                                            ,(find-layer-for-type
  39                                                              type))
  40                                                          (description.layers description)))
  41                   ((attributes description) (or
  42                                              (attributes description)
  43                                              (list-slots object))))
  44             (funcall-with-description
  45              description properties
  46              #'display-using-description description object component))
  47           (error "no description for ~A" object))))
  48
  49 ;;;;; Macros
  50
  51
  52 (defun funcall-with-description (description properties function &rest args)
  53   (if description
  54       (dletf* (((description.type description) (or
  55                                                 (getf properties :type)
  56                                                 (description.type description)))
  57
  58                ((description.layers description) (append
  59                                                          (description.layers description)
  60                                                          (getf properties :layers)))
  61                ((description.properties description) properties))
  62         (funcall-with-layers
  63          (description.layers description)
  64          #'(lambda ()
  65              (contextl::funcall-with-special-initargs
  66               (list (cons description properties))
  67               #'(lambda ()
  68                   (apply function args))))))
  69       (apply function args)))
  70
  71
  72
  73 (defmacro with-description ((description &rest properties) &body body)
  74   `(funcall-with-description ,description (if ',(cdr properties)
  75                                                (list ,@properties)
  76                                                ,(car properties))
  77     #'(lambda ()
  78         ,@body)))
  79
  80 (defmacro do-attributes ((var description &optional (attributes `(attributes ,description))) &body body)
  81   (with-unique-names (att properties type)
  82     `(dolist* (,att  ,attributes)
  83       (let* ((,att (ensure-list ,att))
  84                 (,properties (rest ,att))
  85                 (,type (getf ,properties :type))
  86                 (,var (let ((a (find-attribute ,description (first ,att))))
  87                         (if ,type
  88                             (apply #'make-attribute :name (first ,att) :type ,type ,properties)
  89                             (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
  90         (funcall-with-description ,var ,properties
  91           #'(lambda () ,@body))))))
  92
  93 (defmacro with-component ((component) &body body)
  94   `(let ((self ,component))
  95     (declare (ignorable self))
  96     (flet ((display* (thing &rest args)
  97              (apply #'display ,component thing args))
  98            (display-attribute (attribute obj &optional props)
  99              (if props
 100                  (funcall-with-description
 101                   attribute props
 102                   #'display-using-description attribute obj ,component)
 103                  (display-using-description attribute obj ,component))))
 104       (declare (ignorable #'display* #'display-attribute))
 105       ,@body)))
 106
 107 (defmacro defdisplay (&body body)
 108   (loop with in-layerp = (eq (car body) :in-layer)
 109         with layer = (if in-layerp (cadr body) 't)
 110         for tail on (if in-layerp (cddr body) body)
 111         until (listp (car tail))
 112         collect (car tail) into qualifiers
 113         finally
 114         (when (member :in-layer qualifiers)
 115           (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
 116         (return
 117           (destructuring-bind (description object &optional component) (car tail)
 118             (with-unique-names (d c)
 119               (let (standard-description-p)
 120                 `(define-layered-method
 121                   display-using-description
 122                   :in-layer ,layer
 123                   ,@qualifiers
 124
 125                   (,(cond
 126                      ((listp description)
 127                       (setf d (car description))
 128                       description)
 129                      (t
 130                       (setf d description)
 131                       (setf standard-description-p t)
 132                       `(,d description)))
 133                    ,object
 134                    ,(cond
 135                      ((null component)
 136                       `(,c component))
 137                      ((listp component)
 138                       (setf c (car component))
 139                       component)
 140                      (t
 141                       (setf c component)
 142                       `(,c component))))
 143                   (with-component (,c)
 144                          ,@(cdr tail)))))))))
 145
 146