Include some more new stuff.
[clinton/lisp-on-lines.git] / src / display.lisp
CommitLineData
e7c5f95a 1(in-package :lisp-on-lines)
2
3(defvar *object*)
4(defvar *display*)
5
6(define-layered-function display-using-description (description display object &rest args)
7 (:documentation
8 "Displays OBJECT via description using/in/with/on display"))
9
10(defun display (display object &rest args)
11 (display-using-description (description-of object) display object args))
12
13(define-layered-method display-using-description
14 :around (description display object &rest args)
15 (let ((*display* display)
16 (*object* object))
17 (call-next-method)))
18
19(define-layered-method display-using-description (description display object &rest args)
20 (error "No DISPLAY-USING-DESCRIPTION methods are specified for: ~% DESCRIPTION: ~A ~% DISPLAY: ~A ~% OBJECT: ~A ~% ARGS: ~S
21
22OMGWTF! If you didn't do this, it's a bug!" description display object args))
23
24(defun display-attribute (attribute)
25 (display-using-description attribute *display* *object*))
26
27(defmacro define-display (&body body)
28 (loop with in-layerp = (eq (car body) :in-layer)
29 with layer = (if in-layerp (cadr body) 't)
30 for tail on (if in-layerp (cddr body) body)
31 until (listp (car tail))
32 collect (car tail) into qualifiers
33 finally
34 (when (member :in-layer qualifiers)
35 (error "Incorrect occurrence of :in-layer in defdisplay. Must occur before qualifiers."))
36 (return
37 (destructuring-bind (description-spec &optional (display-spec (gensym)) (object-spec (gensym)))
38 (car tail)
39 `(define-layered-method
40 display-using-description
41 :in-layer ,layer
42 ,@qualifiers
43 (,(if (listp description-spec)
44 (list (first description-spec)
45 (if (eq 'description (second description-spec))
46 'description
47 (defining-description (second description-spec)))))
48 ,display-spec
49 ,object-spec &rest args)
50 (declare (ignorable args))
51 ,@(cdr tail))))))
52
53
54
55