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   (:method-combination wrapping-standard)
   6   (:documentation
   7    "Render the object in component,
   8     using DESCRIPTION, which is an occurence, an attribute, or something else entirely."))
   9
  10 (define-layered-method
  11     display-using-description (d o c)
  12     (<:as-html "default :" o))
  13
  14 (defmethod find-layer-for-type (type)
  15   type)
  16
  17
  18 (define-layered-function display (component object &rest args)
  19   (:documentation
  20    "Displays OBJECT in COMPONENT."))
  21
  22 (define-layered-method display ((component t) (object t)
  23                                 &rest properties
  24                                 &key type (line #'line-in)
  25                                 &allow-other-keys)
  26   " The default display dispatch method
  27
  28   DISPLAY takes two required arguments,
  29   COMPONENT : The component to display FROM (not neccesarily 'in')
  30   OBJECT : The 'thing' we want to display... in this case it's the component
  31
  32   DISPLAY also takes keywords arguments which modify the DESCRIPTION,
  33   that is to say the parameters that come together to create the output.
  34
  35 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
  36
  37   (let* ((description (find-occurence object)))
  38
  39     (if description
  40         (dletf (((description.type description) type)
  41                 ((attributes description) (or
  42                                            (attributes description)
  43                                            (list-slots object))))
  44           ;; apply the default line to the description
  45           (funcall-with-description
  46            description
  47            (funcall line object)
  48            ;; apply the passed in arguments and call display-using-description
  49            #'(lambda ()
  50                (funcall-with-description
  51                 description
  52                 properties
  53                 #'display-using-description description object component))))
  54         (error "no description for ~A" object))))
  55
  56 ;;;;; Macros
  57
  58
  59 (defun funcall-with-description (description properties function &rest args)
  60
  61   (if description
  62       (dletf* (((description.type description) (or
  63                                                 (getf properties :type)
  64                                                 (description.type description)))
  65
  66                ((description.layers description) (append
  67                                                          (description.layers description)
  68                                                          (getf properties :layers)))
  69                ((description.properties description) (append (description.properties description) properties)))
  70         (funcall-with-layers
  71          (description.layers description)
  72          #'(lambda ()
  73              (contextl::funcall-with-special-initargs
  74               (list (cons description properties))
  75               #'(lambda ()
  76                   (apply function args))))))
  77       (apply function args)))
  78
  79
  80
  81 (defmacro with-description ((description &rest properties) &body body)
  82   `(funcall-with-description ,description (if ',(cdr properties)
  83                                                (list ,@properties)
  84                                                ,(car properties))
  85     #'(lambda ()
  86         ,@body)))
  87
  88 (define-layered-function find-do-attributes (desc))
  89
  90 (define-layered-method find-do-attributes ((description description))
  91
  92   (loop
  93      :for att
  94      :in (attributes description)
  95      :collect (let ((default (find (car (ensure-list att))
  96                                    (default-attributes description)
  97                                    :key #'car)))
  98                 (or default att))))
  99
 100 (defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
 101   (with-unique-names (att properties type)
 102     `(dolist* (,att  ,attributes)
 103        (let* ((,att (ensure-list ,att))
 104               (,properties (rest ,att))
 105               (,type (getf ,properties :type))
 106               (,var (let ((a (find-attribute ,description (first ,att))))
 107                       (if ,type
 108                           (apply #'make-attribute :name (first ,att) :type ,type ,properties)
 109                           (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
 110          (funcall-with-description ,var ,properties
 111                                    #'(lambda ()
 112                                        ,@body))))))
 113
 114 (defmacro with-component ((component) &body body)
 115   `(let ((self ,component))
 116     (declare (ignorable self))
 117     (flet ((display* (thing &rest args)
 118              (apply #'display ,component thing args))
 119            (display-attribute (attribute obj &optional props)
 120              (if props
 121                  (funcall-with-description
 122                   attribute props
 123                   #'display-using-description attribute obj ,component)
 124                  (display-using-description attribute obj ,component))))
 125       (declare (ignorable #'display* #'display-attribute))
 126       ,@body)))
 127
 128 (defmacro defdisplay (&body body)
 129   (loop with in-layerp = (eq (car body) :in-layer)
 130         with layer = (if in-layerp (cadr body) 't)
 131         for tail on (if in-layerp (cddr body) body)
 132         until (listp (car tail))
 133         collect (car tail) into qualifiers
 134         finally
 135         (when (member :in-layer qualifiers)
 136           (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
 137         (return
 138           (destructuring-bind (description &optional object component) (car tail)
 139             (with-unique-names (d c)
 140               (let (standard-description-p)
 141                 `(define-layered-method
 142                   display-using-description
 143                   :in-layer ,layer
 144                   ,@qualifiers
 145
 146                   ,@(unless object
 147                             (setf object description)
 148                             (setf description d)
 149                             nil)
 150                   (,(cond
 151                      ((listp description)
 152                       (setf d (car description))
 153                       description)
 154                      (t
 155                       (setf d description)
 156                       (setf standard-description-p t)
 157                       `(,d description)))
 158                    ,object
 159                    ,(cond
 160                      ((null component)
 161                       `(,c component))
 162                      ((listp component)
 163                       (setf c (car component))
 164                       component)
 165                      (t
 166                       (setf c component)
 167                       `(,c component))))
 168                   (with-component (,c)
 169                          ,@(cdr tail)))))))))
 170
 171