Coverage report: /home/ellis/comp/core/lib/obj/meta/mix.lisp

Kind	Covered	All	%
expression	0	203	0.0
branch	0	6	0.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; mix.lisp --- Dynamic Mixin Metaclasses

2

3

;; Originally taken from StumpWM (dynamic-mixins.lisp)

4

5

;;; Commentary:

6

7

#|

8

mixins are for simple, dynamic class combinations:

9

10

(defclass a () ())

11

(defclass b () ())

12

(defclass c () ())

13

14

(make-instance (mix 'a 'b)) ;; => #<MIXIN-OBJECT (A B)>

15

16

(let ((a (make-instance 'a)))

17

(ensure-mix a 'b 'c) ;; => #<MIXIN-OBJECT (B C A)>

18

(delete-from-mix a 'a) ;; => #<MIXIN-OBJECT (B C)>

19

(delete-from-mix a 'c)) ;; => #<B>

20

21

This allows objects to be mixed and updated without manually defining many

22

permutations.

23

|#

24

25

;;; Code:

26

(in-package :obj/meta/mix)

27

28

(defvar *mixin-classes* (make-hash-table :test 'equal))

29

30

(defclass mixin-class (standard-class)

31

((classes :initform nil :initarg :classes :accessor mixin-classes)))

32

33

(defmethod sb-mop:validate-superclass ((class mixin-class) (super standard-class)) t)

34

35

(defmethod print-object ((o mixin-class) stream)

36

(with-slots (classes) o

37

(print-unreadable-object (o stream :identity t)

38

(format stream "~S ~S"

39

(or (class-name o) 'mixin-class)

40

(mapcar #'class-name classes)))))

41

42

(defclass mixin-object () ())

43

44

(defstruct mix-list (list nil))

45

46

(defun %find-class (name-or-class)

47

(etypecase name-or-class

48

(symbol (find-class name-or-class))

49

(class name-or-class)))

50

51

(defun %mix (object-or-class &rest class-list)

52

"Create a MIX-LIST for MAKE-INSTANCE. The first element may be an

53

instance; further elements must be class names or classes."

54

(let ((class0 (typecase object-or-class

55

(symbol (list (find-class object-or-class)))

56

(mixin-object

57

(slot-value (class-of object-or-class) 'classes))

58

(t (list (class-of object-or-class))))))

59

(make-mix-list

60

:list (sort (remove-duplicates

61

(append (mapcar #'%find-class class-list)

62

class0))

63

'symbol-before-p

64

:key 'class-name))))

65

66

(defun mix (&rest classes)

67

(make-mix-list :list (sort (remove-duplicates (mapcar #'%find-class classes))

68

'symbol-before-p

69

:key 'class-name)))

70

71

(defun set-superclasses (class list)

72

(reinitialize-instance class :direct-superclasses list))

73

74

(defun define-mixin (mix-list)

75

(let ((new-class (make-instance 'mixin-class

76

:classes (mix-list-list mix-list))))

77

(handler-case

78

(progn

79

(set-superclasses new-class (list* (find-class 'mixin-object)

80

(mix-list-list mix-list))))

81

(error (e)

82

(set-superclasses new-class nil)

83

(error e)))

84

(setf (gethash (mix-list-list mix-list) *mixin-classes*)

85

new-class)))

86

87

(defun ensure-mixin (mix-list)

88

(if (cdr (mix-list-list mix-list))

89

(if-let ((class (gethash (mix-list-list mix-list)

90

*mixin-classes*)))

91

class

92

(define-mixin mix-list))

93

(car (mix-list-list mix-list))))

94

95

(defun ensure-mix (object &rest classes)

96

(let ((new-class (ensure-mixin (apply #'%mix object classes))))

97

(change-class object new-class)))

98

99

(defun delete-from-mix (object &rest classes)

100

(if (typep object 'mixin-object)

101

(let* ((classes (mapcar #'%find-class classes))

102

(old-classes (slot-value (class-of object) 'classes))

103

(new-classes (remove-if (lambda (x) (member (%find-class x) classes))

104

old-classes))

105

(new-class (if (cdr new-classes)

106

(ensure-mixin (apply #'mix new-classes))

107

(car new-classes))))

108

(change-class object new-class))

109

object))

110

111

(defmethod make-instance ((items mix-list) &rest initargs &key &allow-other-keys)

112

(apply #'make-instance (ensure-mixin items) initargs))

113

114

;;; Protocol

115

(defgeneric replace-class (object new-class &rest initargs))

116

117

(defgeneric replace-class-in-mixin (object new-class old-class &rest initargs)

118

(:method ((object standard-object) n o &rest rest)

119

(declare (ignore o))

120

(apply #'change-class object n rest)))

121

122

;;; Sorting

123

(defvar *class-ordering-rules* nil

124

"A plist of rules for how to order classes for mixing. Keys are the class

125

names. Rules have the following shape:

126

127

(:before ((string-1 . package-designator-1)

128

(string-2 . package-designator-2)

129

...

130

(string-n . package-designator-n))

131

:after ((string-1 . package-designator-1)

132

(string-2 . package-designator-2)

133

...

134

(string-n . package-designator-n)))")

135

136

(defun set-mix-rule (symbol before after)

137

"Add or replace a class ordering rule for SYMBOL."

138

(setf (getf *class-ordering-rules* symbol) (list :before before :after after)))

139

140

(defun symbol-ordering-rules (symbol)

141

(getf *class-ordering-rules* symbol))

142

143

(defun symbol-ordering-rules-before-list (symbol &optional rules)

144

(getf (or rules (symbol-ordering-rules symbol)) :before))

145

146

(defun symbol-ordering-rules-after-list (symbol &optional rules)

147

(getf (or rules (symbol-ordering-rules symbol)) :after))

148

149

(defun symbol-spec-match (symbol spec)

150

(let ((p (find-package (cdr spec))))

151

(when p

152

(eq (find-symbol (string (car spec)) p)

153

symbol))))

154

155

(defun symbol-before-p (s1 s2)

156

"Return truthy if S1 should be before S2."

157

(or (find s2 (symbol-ordering-rules-before-list s1) :test #'symbol-spec-match)

158

(find s1 (symbol-ordering-rules-after-list s2) :test #'symbol-spec-match)))

159

160

(defun symbol-after-p (s1 s2)

161

"Return truthy if S1 should be after S2."

162

(or (find s2 (symbol-ordering-rules-after-list s1) :test #'symbol-spec-match)

163

(find s1 (symbol-ordering-rules-before-list s2) :test #'symbol-spec-match)))