src/defdisplay.lisp

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