src/mao/description.lisp

   1 (in-package :lisp-on-lines)
   2
   3 (defdynamic described-object nil)
   4 (defdynamic description nil)
   5
   6 ;;backwards-compat hacks
   7 (define-symbol-macro *object* (dynamic described-object))
   8 (define-symbol-macro *description* (dynamic description))
   9
  10 ;; forward compat hacks
  11
  12 (defun current-description ()
  13   (dynamic description))
  14
  15 (define-layered-function description-of (thing)
  16   (:method (thing)
  17     (find-description 't)))
  18
  19 (defun description-print-name (description)
  20   (description-class-name (class-of description)))
  21
  22 (defun description-attributes (description)
  23   (alexandria:hash-table-values (description-class-attributes (class-of description))))
  24
  25 (defun description-current-attributes (description)
  26           (remove-if-not
  27            (lambda (attribute)
  28              (and
  29               (some #'layer-active-p
  30                         (mapcar #'find-layer
  31                                 (slot-definition-layers
  32                                  (attribute-effective-attribute-definition attribute))))))
  33            (description-attributes description)))
  34
  35 (defun description-active-attributes (description)
  36           (remove-if-not
  37            #'attribute-active-p
  38            (description-attributes description)))
  39
  40
  41
  42 (define-layered-function description-active-descriptions (description)
  43   (:method ((description t))
  44     (attribute-value (find-attribute description 'active-descriptions)))
  45   (:method ((description attribute))
  46     (attribute-active-descriptions description)))
  47
  48 (define-layered-function description-inactive-descriptions (description)
  49   (:method ((description t))
  50     (attribute-value (find-attribute description 'inactive-descriptions)))
  51   (:method ((description attribute))
  52     (attribute-inactive-descriptions description)))
  53
  54 (define-layered-function attributes (description)
  55   (:method (description)
  56     (let* ((active-attributes
  57             (find-attribute description 'active-attributes))
  58            (attributes (when active-attributes
  59                          (ignore-errors (attribute-value active-attributes)))))
  60       (remove-if-not
  61        (lambda (attribute)
  62          (and attribute
  63               (attribute-active-p attribute)
  64               (some #'layer-active-p
  65                     (attribute-layers attribute))))
  66        (if attributes
  67            (mapcar (lambda (spec)
  68                      (find-attribute
  69                       description
  70                       (if (listp spec)
  71                           (car spec)
  72                           spec)))
  73                    attributes)
  74            (description-attributes description))))))
  75
  76 (defun funcall-with-described-object (function object description &rest args)
  77   (setf description (or description (description-of object)))
  78   (dynamic-let ((description description)
  79                 (object  object))
  80     (dletf (((described-object description) object))
  81         (funcall-with-layer-context
  82          (modify-layer-context (adjoin-layer description (current-layer-context))
  83           :activate (description-active-descriptions description)
  84           :deactivate (description-inactive-descriptions description))
  85          (lambda ()
  86            (with-special-symbol-access
  87              (contextl::funcall-with-special-initargs
  88               (without-special-symbol-access
  89                 (loop
  90                    :for (key val) :on args :by #'cddr
  91                    :collect (list (find key (description-attributes description)
  92                                         :key #'attribute-keyword)
  93                                   :value val)))
  94               (lambda ()
  95                 (contextl::funcall-with-special-initargs
  96                  (without-special-symbol-access
  97                    (let ((attribute (ignore-errors (find-attribute description 'active-attributes))))
  98                      (when attribute
  99                        (loop for spec in (attribute-value attribute)
 100                           if (listp spec)
 101                           collect (cons (or
 102                                          (find-attribute description (car spec))
 103                                          (error "No attribute matching ~A" (car spec)))
 104                                         (cdr spec))))))
 105                  (lambda ()
 106                    (without-special-symbol-access
 107                      (funcall  function))))))))))))
 108
 109 (defmacro with-described-object ((object &optional (description `(description-of ,object)))
 110                                  &body body)
 111   `(funcall-with-described-object (lambda (),@body) ,object ,description))
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132