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