darcs - qt.core

1 (in-package :cl-smoke.qt.core)

3 (defgeneric qt:connect (qsignal slot &optional type)

4 (:documentation "Connects a signal to a slot."))

6 (defgeneric qt:disconnect (qsignal slot)

7 (:documentation "Disconnects a connection."))

9 (defgeneric qt:disconnect-all (qsignal)

10 (:documentation "Disconnects all connections of QSIGNAL."))

12 (defun check-argument-types (signal-arguments slot-arguments)

13 (assert (= (length signal-arguments) (length slot-arguments)))

14 (loop for signal-arg in signal-arguments

15 for slot-arg in slot-arguments do

16 (if (typep signal-arg 'smoke-type)

17 (assert (smoke-type= signal-arg slot-arg))

18 (assert (subtypep signal-arg slot-arg)))))

20 ;;FIXME check argument-types

21 (defmethod qt:connect ((qsignal qsignal) (qslot qslot) &optional type)

22 (assert (or (slot-boundp (signal-object qsignal) 'argument-types)

23 (slot-boundp qslot 'arguments))

24 ((slot-value (signal-object qsignal) 'argument-types)

25 (slot-value qslot 'arguments))

26 "Argument types must be specified for at least on of

27 ~A and ~A." qsignal qslot)

28 (when (not (slot-boundp (signal-object qsignal) 'argument-types))

29 (setf (argument-types (signal-object qsignal))

30 (arguments qslot)))

31 (when (not (slot-boundp qslot 'arguments))

32 (setf (slot-value qslot 'arguments)

33 (argument-types (signal-object qsignal))))

34 (check-argument-types (argument-types (signal-object qsignal))

35 (arguments qslot))

36 (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))

37 qslot (id qslot)

38 type

39 (types (arguments qslot)))

40 (cerror "Failed to connect ~S to ~S." qsignal qslot)))

42 (defmethod qt:connect ((sender qsignal) (function function) &optional type)

43 (let ((slot (make-instance 'qslot

44 :arg0 (signal-object sender)

45 :argument-types (argument-types (signal-object sender))

46 :slot-function function)))

48 (unless (connect-id (signal-object sender) (id (signal-object sender))

49 slot (id slot)

50 type

51 (types (argument-types (signal-object sender))))

52 (cerror "Failed to connect the function ~S to the signal ~S."

53 function sender))))

55 (defclass qt-signal-slot-name ()

56 ((name :initarg :name

57 :reader name)))

59 (defclass qt-signal (qt-signal-slot-name)

60 ((sender :initarg :sender

61 :reader qsender))

62 (:documentation "Qt C++ signal."))

64 (defclass qt-slot (qt-signal-slot-name)

65 ((receiver :initarg :receiver

66 :reader receiver))

67 (:documentation "Qt C++ slot."))

69 (defmethod print-object ((qt-signal qt-signal) stream)

70 (print-unreadable-object (qt-signal stream :type t :identity t)

71 (when (slot-boundp qt-signal 'sender)

72 (princ (qsender qt-signal) stream))

73 (princ " " stream)

74 (when (slot-boundp qt-signal 'name)

75 (princ (name qt-signal) stream))))

77 (defgeneric qt:get-slot (receiver name)

78 (:documentation "Returns the slot of RECEIVER with NAME.")

79 (:method (receiver name)

80 (make-instance 'qt-slot :receiver receiver :name name))

81 (:method (receiver (function function))

82 "Returns a slot for RECEIVER that calls function

83 with RECEIVER as the first argument."

84 (make-instance 'qslot

85 :arg0 receiver

86 :slot-function #'(lambda (&rest args)

87 (apply function (cxx:parent *this*)

88 args)))))

90 (define-compiler-macro qt:get-slot (&whole form receiver name)

91 "Normalize the slot name."

92 (if (stringp name)

93 (let ((normalized-name (cxx:data

94 (qt:meta-object.normalized-signature name))))

95 (if (string= name normalized-name) ;; Avoid infinite recursion

96 form

97 `(qt:get-slot ,receiver ,normalized-name)))

98 form))

100 (defun qt:get-signal (sender name)

101 "Returns the signal NAME of SENDER."

102 (make-instance 'qt-signal :sender sender :name name))

103

104 (define-compiler-macro qt:get-signal (&whole form sender name)

105 "Normalize the signal name."

106 (if (stringp name)

107 (let ((normalized-name (cxx:data

108 (qt:meta-object.normalized-signature name))))

109 (if (string= name normalized-name) ;; Avoid infinite recursion

110 form

111 `(qt:get-signal ,sender ,normalized-name)))

112 form))

113

114 (defmethod qt:connect ((qt-signal qt-signal) (qt-slot qt-slot) &optional type)

115 (unless (qt:object.connect (qsender qt-signal) (qt:qsignal (name qt-signal))

116 (receiver qt-slot) (qt:qslot (name qt-slot))

117 (or type qt:+auto-connection+))

118 (cerror "Ignore"

119 "Failed to connect ~A ~A to ~A ~A."

120 (qsender qt-signal) (name qt-signal)

121 (receiver qt-slot) (name qt-slot))))

122

123 (defmethod qt:disconnect ((qt-signal qt-signal) (qt-slot qt-slot))

124 (unless (qt:object.disconnect (qsender qt-signal) (qt:qsignal (name qt-signal))

125 (receiver qt-slot) (qt:qslot (name qt-slot)))

126 (cerror "Ignore"

127 "Failed to disconnect ~A ~A from ~A ~A."

128 (receiver qt-slot) (name qt-slot)

129 (qsender qt-signal) (name qt-signal))))

130

131 (defmethod qt:disconnect-all ((sender qt:object))

132 (unless (qt:object.disconnect sender 0 0 0)

133 (cerror "Ignore"

134 "Failed to disconnect everything connected to ~A."

135 sender)))

136

137

138 (defmethod qt:connect ((qt-signal qt-signal) (function function) &optional type)

139 (let* ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal)))

140 (slot (make-instance 'qslot

141 :arg0 (qsender qt-signal)

142 :slot-function function

143 :argument-types

144 (method-arguments-type (qsender qt-signal)

145 signal-id))))

146 ;; Ensure that the slot is not gc'ed as long as the QT-SIGNAL

147 ;; exists.

148 ;;

149 ;; FIXME: remove on disconnect.

150 ;; This no not critical because the slot

151 ;; object is not accessible to the user,

152 ;; who thus can not connect it to other

153 ;; signals.

154 (if (connect-id (qsender qt-signal) signal-id

155 slot (id slot)

156 type (types (arguments slot)))

157 (cxx:connect-notify (qsender qt-signal)

158 (name qt-signal))

159 (cerror "Ignore" "Failed to connect the signal ~S of ~S to the function ~S."

160 (name qt-signal) (qsender qt-signal) function))))

161

162 (defmethod qt:connect ((qt-signal qt-signal) (slot qslot) &optional type)

163 (let ((signal-id (find-signal-id (qsender qt-signal) (name qt-signal))))

164 (if (slot-boundp slot 'arguments)

165 (check-argument-types (method-arguments-type (qsender qt-signal)

166 signal-id)

167 (arguments slot))

168 (setf (slot-value slot 'arguments)

169 (method-arguments-type (qsender qt-signal) signal-id)))

170 (if (connect-id (qsender qt-signal) signal-id

171 slot (id slot)

172 type (types (arguments slot)))

173 (cxx:connect-notify (qsender qt-signal)

174 (name qt-signal))

175 (cerror "Ignore" "Failed to connect the signal ~S of ~S to the slot ~S."

176 (name qt-signal) (qsender qt-signal) slot))))

177

178 (defmethod qt:connect ((qsignal qsignal) (slot qt-slot) &optional type)

179 (let ((slot-id (find-slot-id (receiver slot) (name slot))))

180 (if (slot-boundp (signal-object qsignal) 'argument-types)

181 (check-argument-types (argument-types (signal-object slot))

182 (method-arguments-type (receiver slot)

183 slot-id))

184 (setf (argument-types (signal-object qsignal))

185 (method-arguments-type (receiver slot) slot-id)))

186 (unless (connect-id (signal-object qsignal) (id (signal-object qsignal))

187 (receiver slot) slot-id

188 type

189 (types (argument-types (signal-object qsignal))))

190 (cerror "Failed to connect ~S to ~S." qsignal slot))))

191

192

193 (defun connect-id (sender signal-id receiver slot-id type types)

194 (qt:meta-object.connect sender signal-id

195 receiver slot-id

196 (if (null type)

197 qt:+auto-connection+

198 type)

199 types))

200

201 (defun disconnect-id (sender signal-id receiver slot-id)

202 (qt:meta-object.disconnect sender signal-id receiver slot-id))