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