Expanded support for Configurable editing.
[clinton/lisp-on-lines.git] / src / display.lisp
CommitLineData
e7c5f95a 1(in-package :lisp-on-lines)
2
4358148e 3(defvar *description*)
e7c5f95a 4(defvar *display*)
6de8d300 5(defvar *object* nil)
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)
18 (setf context (adjoin-layer (find-description d)
19 context))))
20
21
22
23
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)
27 :activate activate
28 :deactivate deactivate)
29 (lambda ()
30 (apply #'display-using-description (description-of object) display object args))))
e7c5f95a 31
32(define-layered-method display-using-description
33 :around (description display object &rest args)
4358148e 34 (declare (ignorable args))
35 (let ((*description* description)
36 (*display* display)
e7c5f95a 37 (*object* object))
b7657b86 38; (<:as-html " " description "Layer Active?: " (layer-active-p (defining-description 'maxclaims::link-to-viewer)))
e8d4fa45 39 (dletf (((described-object description) object))
b7657b86 40 (flet ((do-display ()
41 (contextl::funcall-with-special-initargs
42 (loop
43 :for (key val) :on args :by #'cddr
44 :collect (list (find key (description-attributes description)
45 :key #'attribute-keyword)
46 :value val))
47 (lambda ()
48 (contextl::funcall-with-special-initargs
49 (let ((attribute (ignore-errors (find-attribute description 'active-attributes))))
50 (when attribute
51 (loop for spec in (attribute-value attribute)
52 if (listp spec)
53 collect (cons (or
54 (find-attribute description (car spec))
55 (error "No attribute matching ~A" (car spec)))
56 (cdr spec)))))
57 (lambda () (call-next-method)))))))
58 (funcall-with-layer-context
59 (modify-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))))))
66
67
68
6de8d300 69
e7c5f95a 70
4271ab0b 71(defun display/d (&rest args)
72 (apply #'display-using-description args))
73
e7c5f95a 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
76
77OMGWTF! If you didn't do this, it's a bug!" description display object args))
78
e7c5f95a 79(defmacro define-display (&body body)
4358148e 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)
e7c5f95a 83 until (listp (car tail))
84 collect (car tail) into qualifiers
85 finally
4358148e 86 (when (member :in-description qualifiers)
87 (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers."))
e7c5f95a 88 (return
89 (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym)))
90 (car tail)
91 `(define-layered-method
92 display-using-description
4358148e 93 :in-layer ,(if (eq t description)
94 t
95 (defining-description description))
e7c5f95a 96 ,@qualifiers
97 (,(if (listp description-spec)
98 (list (first description-spec)
99 (if (eq 'description (second description-spec))
100 'description
101 (defining-description (second description-spec)))))
102 ,display-spec
103 ,object-spec &rest args)
104 (declare (ignorable args))
105 ,@(cdr tail))))))
106
107
108
109