This repository has been archived by the owner on Apr 2, 2023. It is now read-only.
-
-
Notifications
You must be signed in to change notification settings - Fork 5
/
Copy pathconfigurable.lisp
132 lines (114 loc) · 5.88 KB
/
configurable.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
#|
This file is a part of Qtools-UI
(c) 2015 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
Author: Nicolas Hafner <shinmera@tymoon.eu>
|#
(in-package #:org.shirakumo.qtools.ui)
(in-readtable :qtools)
(defclass configurable-class (standard-class)
((options :initarg :options :accessor configurable-class-options)
(option-order :initarg :option-order :accessor configurable-class-option-order))
(:default-initargs
:options ()))
(defmethod shared-initialize :after ((class configurable-class) slots &key (option-order NIL o-p))
(declare (ignore option-order slots))
(unless o-p
(setf (configurable-class-option-order class)
(loop for slot in (c2mop:class-direct-slots class)
collect (c2mop:slot-definition-name slot)))))
(defmethod c2mop:validate-superclass ((class configurable-class) (superclass t))
NIL)
(defmethod c2mop:validate-superclass ((class standard-class) (superclass configurable-class))
T)
(defmethod c2mop:validate-superclass ((class configurable-class) (superclass standard-class))
T)
(defmethod c2mop:validate-superclass ((class configurable-class) (superclass configurable-class))
T)
(defclass configurable-slot ()
((option :initarg :option :initform NIL :accessor configurable-slot-option))
(:documentation "Superclass for configurable slots with an option"))
(defclass configurable-direct-slot-definition (configurable-slot c2mop:standard-direct-slot-definition)
())
(defclass configurable-effective-slot-definition (configurable-slot c2mop:standard-effective-slot-definition)
((direct-slot :initform NIL :accessor configurable-effective-slot-direct-slot)))
(defmethod c2mop:direct-slot-definition-class ((class configurable-class) &rest initargs)
(declare (ignore initargs))
(find-class 'configurable-direct-slot-definition))
(defmethod c2mop:effective-slot-definition-class ((class configurable-class) &rest initargs)
(declare (ignore initargs))
(find-class 'configurable-effective-slot-definition))
(defmethod c2mop:compute-effective-slot-definition ((class configurable-class) name direct-slots)
(declare (ignore name))
(let ((effective-slot (call-next-method)))
(dolist (direct-slot direct-slots)
(when (and (typep direct-slot 'configurable-direct-slot-definition)
(eql (c2mop:slot-definition-name direct-slot)
(c2mop:slot-definition-name effective-slot)))
(setf (slot-value effective-slot 'option)
(copy-list (configurable-slot-option direct-slot)))
(setf (configurable-effective-slot-direct-slot effective-slot) direct-slot)
(return)))
effective-slot))
(defmethod c2mop:finalize-inheritance :after ((class configurable-class))
;; Make sure the slots get the options.
(loop for (name . option) in (configurable-class-options class)
for slot = (find name (c2mop:class-slots class) :key #'c2mop:slot-definition-name)
do (unless slot
(error "Defined option on slot ~s which does not exist on class ~a." name class))
(unless (typep slot 'configurable-slot)
(error "Defined option on slot ~s which is not a configurable-slot on class ~a." name class))
(setf (configurable-slot-option slot) option)))
(defclass configurable ()
()
(:metaclass configurable-class))
(defun coerce-option-for-slot (option slot)
(let ((slot-name (c2mop:slot-definition-name slot)))
(unless (getf option :small)
(setf (getf option :small) T))
;; Almost the same twice.
(unless (getf option :reader)
(case (or (getf option :accessor-type) :accessor)
(:accessor
(let ((reader (first (c2mop:slot-definition-readers
(configurable-effective-slot-direct-slot slot)))))
(cond (reader
(setf (getf option :reader) reader))
(T
(setf (getf option :reader) (lambda (target)
(slot-value target slot-name)))))))
(:slot (setf (getf option :writer) slot-name))
(:function (setf (getf option :reader) (lambda (target)
(slot-value target slot-name))))))
(unless (getf option :writer)
(case (or (getf option :accessor-type) :accessor)
(:accessor
(let ((writer (first (c2mop:slot-definition-writers
(configurable-effective-slot-direct-slot slot)))))
(cond (writer
(setf (getf option :writer) writer))
(T
(setf (getf option :writer) (lambda (value target)
(setf (slot-value target slot-name) value)))))))
(:slot (setf (getf option :writer) slot-name))
(:function (setf (getf option :writer) (lambda (target value)
(setf (slot-value target slot-name) value)))))))
option)
(defgeneric configuration-container (configurable)
(:method ((configurable configurable))
(let ((option-container (make-instance 'option-container)))
(loop for slot-name in (configurable-class-option-order (class-of configurable))
for slot = (find slot-name (c2mop:class-slots (class-of configurable))
:key #'c2mop:slot-definition-name)
for (type . args) = (configurable-slot-option slot)
do (when type
(add-item (apply #'make-option type :target configurable (coerce-option-for-slot args slot))
option-container)))
option-container)))
(defmacro define-configurable (name direct-superclasses direct-slots &rest options)
(unless (find :metaclass options :key #'car)
(push `(:metaclass configurable-class) options))
(push 'configurable direct-superclasses)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass ,name ,direct-superclasses
,direct-slots
,@options)))