1 (in-package :lisp-on-lines
)
7 (define-layered-function display-using-description
(description display object
&rest args
)
9 "Displays OBJECT via description using/in/with/on display"))
13 (defun modify-layer-context (context &key activate deactivate
)
14 (dolist (d deactivate
)
15 (setf context
(remove-layer (find-description d
)
17 (dolist (d activate context
)
18 (setf context
(adjoin-layer (find-description d
)
24 (defun display (display object
&rest args
&key deactivate activate
&allow-other-keys
)
25 (funcall-with-layer-context
26 (modify-layer-context (current-layer-context)
28 :deactivate deactivate
)
30 (apply #'display-using-description
(description-of object
) display object args
))))
32 (define-layered-method display-using-description
33 :around
(description display object
&rest args
)
34 (declare (ignorable args
))
35 (let ((*description
* description
)
38 ; (<:as-html " " description "Layer Active?: " (layer-active-p (defining-description 'maxclaims::link-to-viewer)))
39 (dletf (((described-object description
) object
))
41 (contextl::funcall-with-special-initargs
43 :for
(key val
) :on args
:by
#'cddr
44 :collect
(list (find key
(description-attributes description
)
45 :key
#'attribute-keyword
)
48 (contextl::funcall-with-special-initargs
49 (let ((attribute (ignore-errors (find-attribute description
'active-attributes
))))
51 (loop for spec in
(attribute-value attribute
)
54 (find-attribute description
(car spec
))
55 (error "No attribute matching ~A" (car spec
)))
57 (lambda () (call-next-method)))))))
58 (funcall-with-layer-context
60 (if (standard-description-p description
)
61 (adjoin-layer description
(current-layer-context))
62 (current-layer-context))
63 :activate
(description-active-descriptions description
)
64 :deactivate
(description-inactive-descriptions description
))
65 (function do-display
))))))
71 (defun display/d
(&rest args
)
72 (apply #'display-using-description args
))
74 (define-layered-method display-using-description
(description display object
&rest args
)
75 (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S
77 OMGWTF! If you didn't do this, it's a bug!" description display object args
))
79 (defmacro define-display
(&body body
)
80 (loop with in-descriptionp
= (eq (car body
) :in-description
)
81 with description
= (if in-descriptionp
(cadr body
) 't
)
82 for tail on
(if in-descriptionp
(cddr body
) body
)
83 until
(listp (car tail
))
84 collect
(car tail
) into qualifiers
86 (when (member :in-description qualifiers
)
87 (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers."))
89 (destructuring-bind (description-spec &optional
(display-spec (gensym)) (object-spec (gensym)))
91 `(define-layered-method
92 display-using-description
93 :in-layer
,(if (eq t description
)
95 (defining-description description
))
97 (,(if (listp description-spec
)
98 (list (first description-spec
)
99 (if (eq 'description
(second description-spec
))
101 (defining-description (second description-spec
)))))
103 ,object-spec
&rest args
)
104 (declare (ignorable args
))