Commit | Line | Data |
---|---|---|
e7c5f95a | 1 | (in-package :lisp-on-lines) |
2 | ||
b1c8f43b | 3 | |
e7c5f95a | 4 | (defvar *display*) |
b1c8f43b | 5 | |
6de8d300 | 6 | |
e7c5f95a | 7 | (define-layered-function display-using-description (description display object &rest args) |
8 | (:documentation | |
9 | "Displays OBJECT via description using/in/with/on display")) | |
10 | ||
b7657b86 | 11 | |
12 | ||
13 | (defun modify-layer-context (context &key activate deactivate) | |
14 | (dolist (d deactivate) | |
15 | (setf context (remove-layer (find-description d) | |
16 | context))) | |
17 | (dolist (d activate context) | |
3a420e7d | 18 | (setf context (adjoin-layer (find-description (if (consp d) (car d) d)) |
b7657b86 | 19 | context)))) |
b7657b86 | 20 | |
f56d6e7e | 21 | (defun funcall-with-attribute-context (attribute thunk) |
22 | (funcall-with-layer-context | |
3a420e7d | 23 | (modify-layer-context (current-layer-context) |
f56d6e7e | 24 | :activate (attribute-active-descriptions attribute) |
25 | :deactivate (attribute-inactive-descriptions attribute)) | |
3a420e7d CE |
26 | (lambda () |
27 | (with-special-symbol-access | |
28 | (contextl::funcall-with-special-initargs | |
ddf67d6b CE |
29 | (without-special-symbol-access |
30 | (mappend (lambda (desc) | |
31 | (when (consp desc) | |
32 | (let ((description (find-description (car desc)))) | |
33 | (loop | |
34 | :for (key val) :on (cdr desc) :by #'cddr | |
35 | :collect (list (find key (description-attributes description) | |
36 | :key #'attribute-keyword) | |
37 | :value val))))) | |
38 | (attribute-active-descriptions attribute))) | |
3a420e7d CE |
39 | (lambda () |
40 | (without-special-symbol-access | |
41 | (funcall thunk)))))))) | |
b7657b86 | 42 | |
f56d6e7e | 43 | (defmacro with-attribute-context ((attribute) &body body) |
44 | `(funcall-with-attribute-context ,attribute (lambda () ,@body))) | |
45 | ||
46 | ||
b7657b86 | 47 | (defun display (display object &rest args &key deactivate activate &allow-other-keys) |
48 | (funcall-with-layer-context | |
49 | (modify-layer-context (current-layer-context) | |
50 | :activate activate | |
51 | :deactivate deactivate) | |
52 | (lambda () | |
53 | (apply #'display-using-description (description-of object) display object args)))) | |
e7c5f95a | 54 | |
55 | (define-layered-method display-using-description | |
eeed4326 | 56 | :around ((description standard-description-object) display object &rest args) |
4358148e | 57 | (declare (ignorable args)) |
46440824 | 58 | #+nil (break "Entering DISPLAY for ~A on ~A using ~A" object display description) |
b1c8f43b | 59 | (let ((*display* display)) |
60 | (apply #'funcall-with-described-object | |
61 | (lambda () | |
62 | (call-next-method)) | |
63 | object description args))) | |
b7657b86 | 64 | |
65 | ||
66 | ||
eeed4326 | 67 | |
4271ab0b | 68 | (defun display/d (&rest args) |
69 | (apply #'display-using-description args)) | |
70 | ||
e7c5f95a | 71 | (define-layered-method display-using-description (description display object &rest args) |
72 | (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S | |
73 | ||
74 | OMGWTF! If you didn't do this, it's a bug!" description display object args)) | |
75 | ||
e7c5f95a | 76 | (defmacro define-display (&body body) |
4358148e | 77 | (loop with in-descriptionp = (eq (car body) :in-description) |
78 | with description = (if in-descriptionp (cadr body) 't) | |
79 | for tail on (if in-descriptionp (cddr body) body) | |
e7c5f95a | 80 | until (listp (car tail)) |
81 | collect (car tail) into qualifiers | |
82 | finally | |
4358148e | 83 | (when (member :in-description qualifiers) |
84 | (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers.")) | |
e7c5f95a | 85 | (return |
86 | (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym))) | |
87 | (car tail) | |
b1c8f43b | 88 | `(define-layered-method |
e7c5f95a | 89 | display-using-description |
4358148e | 90 | :in-layer ,(if (eq t description) |
91 | t | |
92 | (defining-description description)) | |
e7c5f95a | 93 | ,@qualifiers |
94 | (,(if (listp description-spec) | |
95 | (list (first description-spec) | |
96 | (if (eq 'description (second description-spec)) | |
97 | 'description | |
eeed4326 | 98 | (contextl::defining-layer (defining-description (second description-spec)))))) |
e7c5f95a | 99 | ,display-spec |
100 | ,object-spec &rest args) | |
101 | (declare (ignorable args)) | |
102 | ,@(cdr tail)))))) | |
103 | ||
104 | ||
105 | ||
106 |