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