darcs - commonqt

2 ;;;

3 ;;; This program is free software: you can redistribute it and/or modify

4 ;;; it under the terms of the GNU General Public License as published by

5 ;;; the Free Software Foundation, either version 3 of the License, or

6 ;;; (at your option) any later version.

7 ;;;

8 ;;; This program is distributed in the hope that it will be useful,

9 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of

10 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

11 ;;; GNU General Public License for more details.

12 ;;;

13 ;;; You should have received a copy of the GNU General Public License

14 ;;; along with this program. If not, see <http://www.gnu.org/licenses/>.

15 ;;;

16 ;;; As a special exception, the copyright holders of this library give you

17 ;;; permission to link this library with independent modules to produce an

18 ;;; executable, regardless of the license terms of these independent

19 ;;; modules, and to copy and distribute the resulting executable under

20 ;;; terms of your choice, provided that you also meet, for each linked

21 ;;; independent module, the terms and conditions of the license of that

22 ;;; module. An independent module is a module which is not derived from or

23 ;;; based on this library. If you modify this library, you may extend this

24 ;;; exception to your version of the library, but you are not obligated to

25 ;;; do so. If you do not wish to do so, delete this exception statement

26 ;;; from your version.

28 (in-package :cl-smoke.commonqt)

30 ;; FIXME

31 ;; There is a GLOBAL-SPACE class per module, for now we just use the :qt.core one.

32 ;; But it should be selected in the method call. e.g.: (#_qVersion "GlobalSpace")

33 (eval-when (:compile-toplevel :load-toplevel :execute)

34 (import 'cl-smoke.qt.core::global-space :cl-smoke.qt))

36 ;;; initialization

37 (defun ensure-smoke ())

38 (defun enable-syntax ())

40 ;;; calling methods

41 ;;;

42 ;;; #_ reader macro

43 ;;;

44 ;;; FIXME: Return reference arguments using multiple return values.

45 ;;;

46 (eval-when (:load-toplevel :compile-toplevel :execute)

47 (defun read-perserving-case (stream)

48 (let ((*readtable* (copy-readtable nil)))

49 (setf (readtable-case *readtable*) :preserve)

50 (read stream)))

52 (defun cl-smoke-funcall-form (stream subchar arg)

53 (declare (ignore subchar arg))

54 (let ((method (read-perserving-case stream)))

55 (if (string= "new" (symbol-name method))

56 `(lambda (&rest args)

57 (make-instance

58 ',(smoke::lispify (symbol-name (read-perserving-case stream)) :cl-smoke.qt)

59 :args args))

60 (let ((object (read stream)))

61 (if (stringp object)

62 (if (upper-case-p (char (symbol-name method) 0))

63 `(lambda ()

64 ,(smoke::lispify

65 (concatenate 'string

66 (if (string= "Qt" object)

67 "+"

68 (concatenate 'string

69 object

70 ".+"))

71 (symbol-name method) "+")

72 :cl-smoke.qt))

73 `(lambda (&rest args)

74 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))

75 (find-class ',(smoke::lispify object :cl-smoke.qt))

76 args)))

77 `(lambda (&rest args)

78 (apply (symbol-function ',(smoke::lispify (symbol-name method) :cxx))

79 ,object

80 args))))))))

82 (eval-when (:load-toplevel :compile-toplevel)

83 (set-dispatch-macro-character #\# #\_ #'cl-smoke-funcall-form))

85 ;;; Instantiating

86 ;;;

87 (defun new (instance &rest arguments)

88 "Calls the C++ construor for INSTANCE with ARGUMENTS."

89 (assert (null-pointer-p (smoke:pointer instance))

90 (instance)

91 "The instance ~A is already constructed." instance)

92 (setf (slot-value instance 'smoke:pointer)

93 (smoke::call-constructor (class-of instance) arguments))

94 (smoke::set-binding instance)

95 (smoke::take-ownership instance)

96 (smoke::add-object instance)

97 instance)

99 ;;; Connecting signals and slots

100 ;;;

101 (defun qsignal (name)

102 (cl-smoke.qt:qsignal name))

103 (defun qslot (name)

104 (cl-smoke.qt:qslot name))

105

106 ;;; QApplication

107 ;;;

108 (defun make-qapplication (&rest arguments)

109 "Returns a new QApplication instance with ARGUMENTS as command line

110 arguments argv. argv[0] is set to (LISP-IMPLEMNTATION-TYPE)."

111 (let* ((argc (smoke:make-auto-pointer

112 (cffi:foreign-alloc :int

113 :initial-element (1+ (length arguments)))))

114 (argv (smoke:make-auto-pointer

115 (cffi:foreign-alloc :string

116 :initial-contents

117 (cons (lisp-implementation-type) ;; arg0

118 arguments))))

119 (application (make-instance 'cl-smoke.qt:application :args

120 (list argc argv))))

121 ;; argc & argv must remain valid during the lifetime of application.

122 (setf (cl-smoke.qt:property application 'arguments)

123 (cl-smoke.qt:make-lisp-variant (cons argc argv)))

124 application))

125

126 ;;; Overriding C++ methods

127 (defclass override-gf (standard-generic-function)

128 ((cxx-gf :initarg :cxx-gf

129 :reader cxx-gf))

130 (:metaclass closer-mop:funcallable-standard-class)

131 (:documentation "Redirects its methods to CXX-GF."))

132

133 (defmethod add-method ((gf override-gf) method)

134 (add-method (cxx-gf gf) method))

135

136 (defmethod remove-method ((gf override-gf) method)

137 (remove-method (cxx-gf gf) method))

138

139 ;;; Subclassing C++ & defining signals and slots

140 ;;;

141 (defclass qt-class (cxx:class)

142 ((method-functions :accessor method-functions

143 :documentation "The signals and slots.")

144 (meta-object :reader class-meta-object))

145 (:documentation "Metaclass for a class derived from QObject, that allows

146 adding signals and slots to the class."))

147

148 (defclass signal-slot-mixin ()

149 ()

150 (:documentation "Mixin for a class with metaclass QT-CLASS, that overwrites

151 the metaObject and qtMetacall methods."))

152

153 (defun setup-meta-object (class qt-superclass signals slots)

154 (let ((methods (make-array (+ (length signals)

155 (length slots))

156 :element-type 'function

157 :initial-element #'identity))

158 (index 0))

159 (dolist (signal-name signals)

160 (setf (aref methods index)

161 (let ((signal-name (first signal-name)))

162 #'(lambda (this &rest args)

163 (apply #'emit-signal this signal-name args))))

164 (incf index))

165 (dolist (slot slots)

166 (setf (aref methods index)

167 (if (symbolp (second slot))

168 (second slot)

169 (eval `(function ,(second slot)))))

170 (incf index))

171 (setf (method-functions class) methods))

172 (let ((signals (mapcar #'(lambda (s) (make-slot-or-signal (first s)))

173 signals))

174 (slots (mapcar #'(lambda (s) (make-slot-or-signal (first s)))

175 slots))

176 (class-name (class-name class)))

177 (setf (slot-value class 'meta-object)

178 (make-metaobject qt-superclass

179 (format nil "~A::~A"

180 (package-name (symbol-package class-name))

181 (symbol-name class-name))

182 nil

183 signals

184 slots))))

185

186 (defun setup-qt-class (qt-class next-method &rest args &key qt-superclass

187 direct-superclasses direct-default-initargs

188 slots signals

189 override &allow-other-keys)

190 (dolist (method override)

191 (ensure-generic-function

192 (second method)

193 :generic-function-class (find-class 'override-gf)

194 :lambda-list '(this &rest args)

195 :cxx-gf (fdefinition (smoke::lispify (first method) :cxx))))

196 (apply next-method qt-class

197 :direct-default-initargs ;; the C++ instance is constructed with #'NEW

198 (cons `(:pointer (null-pointer) ,#'null-pointer)

199 direct-default-initargs)

200 :direct-superclasses

201 (append (list (find-qclass (first qt-superclass))

202 (find-class 'signal-slot-mixin))

203 direct-superclasses)

204 args)

205 (setup-meta-object qt-class (find-qclass (first qt-superclass))

206 signals slots))

207

208 (defmethod cxx:meta-object ((this signal-slot-mixin))

209 (class-meta-object (class-of this)))

210

211 (defmethod cxx:qt-metacall ((this signal-slot-mixin) call id arguments)

212 (let ((m-id (call-next-method)))

213 (if (< m-id 0)

214 m-id

215 (if (enum= call cl-smoke.qt:meta-object.+invoke-meta-method+)

216 (progn

217 (when (< m-id (length (method-functions (class-of this))))

218 (with-simple-restart

219 (continue "Skip the method ~A of ~A."

220 (cxx:signature

221 (cxx:method (cxx:meta-object this) id))

222 this)

223 (apply (aref (method-functions (class-of this)) m-id)

224 this

225 (cl-smoke.qt.core::arguments-to-lisp

226 arguments

227 (cl-smoke.qt.core::method-arguments-type this id)))))

228 (- m-id

229 (length (method-functions (class-of this)))))

230 m-id))))

231

232 (defmethod initialize-instance :around ((class qt-class)

233 &rest args &key &allow-other-keys)

234 (apply #'setup-qt-class class #'call-next-method args))

235

236 (defmethod reinitialize-instance :around ((qt-class qt-class)

237 &rest args &key &allow-other-keys)

238 (apply #'setup-qt-class qt-class #'call-next-method args))

239

240 (defun emit-signal (object signal-name &rest arguments)

241 "Emits the signal SIGNAL-NAME of OBJECT using ARGUMENTS."

242 (declare (string signal-name))

243 (let* ((meta-object (class-meta-object (class-of object)))

244 (id (#_indexOfSignal meta-object

245 (#_normalizedSignature "QMetaObject"

246 signal-name))))

247 (assert (>= id 0)

248 ()

249 "No signal ~A of ~A." signal-name object)

250 (cl-smoke.qt.core::activate

251 object id (cl-smoke.qt.core::method-arguments-type object id)

252 arguments)))

253

254 (defmacro call-next-qmethod ()

255 "Calls the next method."

256 '(call-next-method))

257

258 ;;; Enum values

259 ;;;

260 (defun primitive-value (enum)

261 "Returns the integer value of ENUM."

262 (cxx-support:value enum))

263

264 ;;; Type disambiguation

265 ;;;

266 (defun bool (value)

267 "Returns true when VALUE is not 0 and false when it is 0."

268 (not (zerop value)))

269

270 ;; No-op since we have overload resolution.

271 (setf (fdefinition 'uint) #'identity

272 (fdefinition 'int) #'identity

273 (fdefinition 'qstring) #'identity)

274

275 (defun find-qclass (class-name)

276 "Returns the CLOS class for the C++ CLASS-NAME string."

277 (find-class (smoke::lispify class-name :cl-smoke.qt)))

278

279 ;;; Documentation

280 ;;;

281

282 (defun qapropos (name)

283 (smoke::fgrep-classes cl-smoke.qt.core::*smoke-module* name)

284 (smoke::fgrep-classes cl-smoke.qt.gui::*smoke-module* name)

285 (smoke::fgrep-methods cl-smoke.qt.core::*smoke-module* name)

286 (smoke::fgrep-methods cl-smoke.qt.gui::*smoke-module* name))

287

288 ;; FIXME: implement QDESCRIBE

289 (defun qdescribe (name)

290 (declare (ignore name))

291 (warn "QDESCRIBE not implemented."))