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 (defun make-display-function (component object
  10                               &rest properties
  11                               &key  (line #'line-in)
  12                               &allow-other-keys)
  13   "returns a function that expects a 3 argument function as its argument
  14
  15 The function argument (which is usually display-using-description) will be called with the proper environment for display all set up nice n pretty like."
  16
  17   (lambda (function)
  18     (let* ((description (find-occurence object)))
  19       (if description
  20           (dletf (((attributes description)
  21                    (or
  22                     (attributes description)
  23                     (list-attributes description))))
  24             ;; apply the default line to the description
  25             (funcall-with-description
  26              description
  27              (funcall line object)
  28              ;; apply the passed in arguments and call display-using-description
  29              #'(lambda ()
  30                  (funcall-with-description
  31                   description
  32                   properties
  33                   function description object component))))
  34           (error "no description for ~A" object)))))
  35
  36 (define-layered-function display (component object &rest args)
  37   (:documentation
  38    "Displays OBJECT in COMPONENT."))
  39
  40 (define-layered-method display ((component t) (object t)
  41                                 &rest properties)
  42   " The default display dispatch method
  43
  44   DISPLAY takes two required arguments,
  45   COMPONENT : The component to display FROM (not neccesarily 'in')
  46   OBJECT : The 'thing' we want to display... in this case it's the component
  47
  48   DISPLAY also takes keywords arguments which modify the DESCRIPTION,
  49   that is to say the parameters that come together to create the output.
  50
  51 The default display calls out via FUNCALL-WITH-LAYERS to tche DISPLAY-USING-DESCRIPTION method."
  52   (funcall (apply 'make-display-function component object properties)
  53            'display-using-description))
  54
  55 ;;;;; Macros
  56
  57 (defun funcall-with-layers (layers thunk)
  58   (let ((context (current-layer-context)))
  59     (loop :for (op layer)
  60        :on layers :by #'cddr
  61        :do (setf context
  62                  (case op
  63                    (+ (adjoin-layer layer context))
  64                    (- (remove-layer layer context)))))
  65     (funcall-with-layer-context context thunk)))
  66
  67
  68 (defun funcall-with-description (description properties function &rest args)
  69   (if description
  70       (dletf* (((description-type description)
  71                 (or
  72                  (getf properties :type)
  73                  (description-type description)))
  74
  75                ((description-layers description)
  76                 (append
  77                  (description-layers description)
  78                  (getf properties :layers)))
  79                ((description-properties description) (append (description-properties description) properties)))
  80         (funcall-with-layers
  81          (description-layers description)
  82          (lambda ()
  83            (contextl::funcall-with-special-initargs
  84             (list (cons description properties))
  85             #'(lambda ()
  86                 (apply function args))))))
  87       (apply function args)))
  88
  89 (defmacro with-description ((description &rest properties) &body body)
  90   `(funcall-with-description ,description (if ',(cdr properties)
  91                                                (list ,@properties)
  92                                                ,(car properties))
  93     #'(lambda ()
  94         ,@body)))
  95
  96 (define-layered-function find-do-attributes (desc))
  97
  98 (define-layered-method find-do-attributes ((description description))
  99
 100   (loop
 101      :for att
 102      :in (attributes description)
 103      :collect (let ((default (find (car (ensure-list att))
 104                                    (default-attributes description)
 105                                    :key #'car)))
 106                 (or default att))))
 107
 108 (defmacro do-attributes ((var description &optional (attributes `(find-do-attributes ,description))) &body body)
 109   (with-unique-names (att properties type)
 110     `(dolist* (,att  ,attributes)
 111        (let* ((,att (ensure-list ,att))
 112               (,properties (rest ,att))
 113               (,type (getf ,properties :type))
 114               (,var (let ((a (find-attribute ,description (first ,att))))
 115                       (if ,type
 116                           (apply #'make-attribute :name (first ,att) :type ,type ,properties)
 117                           (if a a (make-attribute :name (first ,att) :slot-name (first ,att)))))))
 118          (funcall-with-description ,var ,properties
 119                                    #'(lambda ()
 120                                        ,@body))))))
 121
 122 (defmacro with-component ((component) &body body)
 123   `(let ((self ,component))
 124     (declare (ignorable self))
 125     (flet ((display* (thing &rest args)
 126              (apply #'display ,component thing args))
 127            (display-attribute (attribute obj &rest
 128                                          props)
 129              (if props
 130                  (funcall-with-description
 131                   attribute props
 132                   #'display-using-description attribute obj ,component)
 133                  (display-using-description attribute obj ,component))))
 134       (declare (ignorable #'display* #'display-attribute))
 135       ,@body)))
 136
 137
 138
 139