src/description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defvar *object* nil)
   4 (defvar *description*)
   5
   6 (define-layered-function description-of (thing)
   7   (:method (thing)
   8     (find-description 't)))
   9
  10 (defun description-print-name (description)
  11   (description-class-name (class-of description)))
  12
  13 (defun description-attributes (description)
  14   (description-class-attributes (class-of description)))
  15
  16 (defun description-current-attributes (description)
  17           (remove-if-not
  18            (lambda (attribute)
  19              (and
  20               (some #'layer-active-p
  21                         (mapcar #'find-layer
  22                                 (slot-definition-layers
  23                                  (attribute-effective-attribute-definition attribute))))))
  24            (description-attributes description)))
  25
  26 (defun description-active-attributes (description)
  27           (remove-if-not
  28            #'attribute-active-p
  29            (description-attributes description)))
  30
  31 (defun find-attribute (description attribute-name &optional (errorp t))
  32   (or (find attribute-name (description-attributes description)
  33             :key #'attribute-name)
  34       (when errorp (error "No attribute named ~A found in ~A describing ~A" attribute-name description (described-object description)))))
  35
  36 (define-layered-function description-active-descriptions (description)
  37   (:method ((description standard-description-object))
  38     (attribute-value (find-attribute description 'active-descriptions)))
  39   (:method ((description attribute))
  40     (attribute-active-descriptions description)))
  41
  42 (define-layered-function description-inactive-descriptions (description)
  43   (:method ((description standard-description-object))
  44     (attribute-value (find-attribute description 'inactive-descriptions)))
  45   (:method ((description attribute))
  46     (attribute-inactive-descriptions description)))
  47
  48 (define-layered-function attributes (description)
  49   (:method (description)
  50     (let* ((active-attributes
  51             (find-attribute description 'active-attributes))
  52            (attributes (when active-attributes
  53                          (ignore-errors (attribute-value active-attributes)))))
  54       (remove-if-not
  55        (lambda (attribute)
  56          (and attribute
  57               (attribute-active-p attribute)
  58               (some #'layer-active-p
  59                     (mapcar #'find-layer
  60                             (slot-definition-layers
  61                              (attribute-effective-attribute-definition attribute))))))
  62        (if attributes
  63            (mapcar (lambda (spec)
  64                      (find-attribute
  65                       description
  66                       (if (listp spec)
  67                           (car spec)
  68                           spec)))
  69                    attributes)
  70            (description-attributes description))))))
  71
  72
  73 (defun funcall-with-described-object (function object description &rest args)
  74   (setf description (or description (description-of object)))
  75   (let ((*description* description)
  76         (*object*  object))
  77     (dletf (((described-object *description*) object))
  78         (funcall-with-layer-context
  79          (modify-layer-context
  80           (if (standard-description-p *description*)
  81               (adjoin-layer *description* (current-layer-context))
  82               (current-layer-context))
  83           :activate (description-active-descriptions *description*)
  84           :deactivate (description-inactive-descriptions *description*))
  85          (lambda () (contextl::funcall-with-special-initargs
  86                      (loop
  87                         :for (key val) :on args :by #'cddr
  88                         :collect (list (find key (description-attributes *description*)
  89                                              :key #'attribute-keyword)
  90                                        :value val))
  91                      (lambda ()
  92                        (contextl::funcall-with-special-initargs
  93                         (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))
  94                           (when attribute
  95                             (loop for spec in (attribute-value attribute)
  96                                if (listp spec)
  97                                collect (cons (or
  98                                               (find-attribute *description* (car spec))
  99                                               (error "No attribute matching ~A" (car spec)))
 100                                              (cdr spec)))))
 101                         function))))))))
 102
 103
 104
 105
 106 (defmacro define-description (name &optional superdescriptions &body options)
 107   (let ((description-name (defining-description name)))
 108     (destructuring-bind (&optional slots &rest options) options
 109       (let ((description-layers (cdr (assoc :in-description options))))
 110         (if description-layers
 111             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 112                ,@(loop
 113                     :for layer
 114                     :in description-layers
 115                     :collect `(define-description
 116                                   ,name ,superdescriptions ,slots
 117                                   ,@(acons
 118                                     :in-layer (defining-description layer)
 119                                     (remove :in-description options :key #'car)))))
 120             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 121                                         ;  `(progn
 122                (defclass ,description-name
 123                    ,(append (mapcar #'defining-description
 124                                     superdescriptions)
 125                             (unless (or (eq t name)
 126                                         (assoc :mixinp options))
 127                               (list (defining-description t))))
 128                  ,(if slots slots '())
 129                  ,@options
 130                  ,@(unless (assoc :metaclass options)
 131                            '((:metaclass standard-description-class))))
 132                (initialize-descriptions)
 133                (find-description ',name)))))))
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153