Properties are special now!
[clinton/lisp-on-lines.git] / src / display.lisp
1 (in-package :lisp-on-lines)
2
3 (defvar *description*)
4 (defvar *display*)
5 (defvar *object* nil)
6
7
8 (deflayer display-layer)
9
10 (define-layered-function display-using-description (description display object &rest args)
11 (:documentation
12 "Displays OBJECT via description using/in/with/on display"))
13
14 (defun display (display object &rest args &key attributes )
15 (let ((*display-attributes* attributes))
16 (apply #'display-using-description (description-of object) display object args)))
17
18 (define-layered-method display-using-description
19 :around (description display object &rest args)
20 (declare (ignorable args))
21 (let ((*description* description)
22 (*display* display)
23 (*object* object))
24 (contextl::funcall-with-special-initargs
25 (loop
26 :for (key val) :on args :by #'cddr
27 :collect (list (find key (description-attributes description)
28 :key #'attribute-keyword)
29 :value val))
30 (lambda ()
31 (contextl::funcall-with-special-initargs
32 (let ((attribute (find-attribute description 'active-attributes)))
33 (when attribute
34 (loop for spec in (attribute-value object attribute)
35 if (listp spec)
36 collect (cons (or
37 (find-attribute description (car spec))
38 (error "No attribute matching ~A" (car spec)))
39 (cdr spec)))))
40 (lambda ()
41 (call-next-method)))))))
42
43
44
45 (defun display/d (&rest args)
46 (apply #'display-using-description args))
47
48 (define-layered-method display-using-description (description display object &rest args)
49 (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S
50
51 OMGWTF! If you didn't do this, it's a bug!" description display object args))
52
53 (defmacro define-display (&body body)
54 (loop with in-descriptionp = (eq (car body) :in-description)
55 with description = (if in-descriptionp (cadr body) 't)
56 for tail on (if in-descriptionp (cddr body) body)
57 until (listp (car tail))
58 collect (car tail) into qualifiers
59 finally
60 (when (member :in-description qualifiers)
61 (error "Incorrect occurrence of :in-description in defdisplay. Must occur before qualifiers."))
62 (return
63 (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym)))
64 (car tail)
65 `(define-layered-method
66 display-using-description
67 :in-layer ,(if (eq t description)
68 t
69 (defining-description description))
70 ,@qualifiers
71 (,(if (listp description-spec)
72 (list (first description-spec)
73 (if (eq 'description (second description-spec))
74 'description
75 (defining-description (second description-spec)))))
76 ,display-spec
77 ,object-spec &rest args)
78 (declare (ignorable args))
79 ,@(cdr tail))))))
80
81
82
83