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" attribute-name 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       (if attributes
  55           (mapcar (lambda (spec)
  56                     (find-attribute
  57                      description
  58                      (if (listp spec)
  59                          (car spec)
  60                          spec)))
  61                   attributes)
  62           (remove-if-not
  63            (lambda (attribute)
  64              (and (attribute-active-p attribute)
  65                   (some #'layer-active-p
  66                         (mapcar #'find-layer
  67                                 (slot-definition-layers
  68                                  (attribute-effective-attribute-definition attribute))))))
  69            (description-attributes description))))))
  70
  71
  72 (defun funcall-with-described-object (function object description &rest args)
  73   (setf description (or description (description-of object)))
  74   (let ((*description* description)
  75         (*object*  object))
  76     (dletf (((described-object *description*) object))
  77         (funcall-with-layer-context
  78          (modify-layer-context
  79           (if (standard-description-p *description*)
  80               (adjoin-layer *description* (current-layer-context))
  81               (current-layer-context))
  82           :activate (description-active-descriptions *description*)
  83           :deactivate (description-inactive-descriptions *description*))
  84          (lambda () (contextl::funcall-with-special-initargs
  85                      (loop
  86                         :for (key val) :on args :by #'cddr
  87                         :collect (list (find key (description-attributes *description*)
  88                                              :key #'attribute-keyword)
  89                                        :value val))
  90                      (lambda ()
  91                        (contextl::funcall-with-special-initargs
  92                         (let ((attribute (ignore-errors (find-attribute *description* 'active-attributes))))
  93                           (when attribute
  94                             (loop for spec in (attribute-value attribute)
  95                                if (listp spec)
  96                                collect (cons (or
  97                                               (find-attribute *description* (car spec))
  98                                               (error "No attribute matching ~A" (car spec)))
  99                                              (cdr spec)))))
 100                         function))))))))
 101
 102
 103 (defmacro with-described-object ((object description &rest args)
 104                                  &body body)
 105     `(funcall-with-described-object
 106       (lambda () ,@body)
 107       ,object
 108       ,description
 109       ,@args))
 110
 111 (defmacro define-description (name &optional superdescriptions &body options)
 112   (let ((description-name (defining-description name)))
 113     (destructuring-bind (&optional slots &rest options) options
 114       (let ((description-layers (cdr (assoc :in-description options))))
 115         (if description-layers
 116             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 117                ,@(loop
 118                     :for layer
 119                     :in description-layers
 120                     :collect `(define-description
 121                                   ,name ,superdescriptions ,slots
 122                                   ,@(acons
 123                                     :in-layer (defining-description layer)
 124                                     (remove :in-description options :key #'car)))))
 125             `(progn ;eval-when (:compile-toplevel :load-toplevel :execute)
 126                                         ;  `(progn
 127                (defclass ,description-name
 128                    ,(append (mapcar #'defining-description
 129                                     superdescriptions)
 130                             (unless (or (eq t name)
 131                                         (assoc :mixinp options))
 132                               (list (defining-description t))))
 133                  ,(if slots slots '())
 134                  ,@options
 135                  ,@(unless (assoc :metaclass options)
 136                            '((:metaclass standard-description-class))))
 137                (initialize-descriptions)
 138                (find-description ',name)))))))
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158