add missing meta type handling for QMatrix, QTransform
[eql:eql.git] / src / lisp / ini.lisp
1 ;;; copyright (c) 2010-2011 Polos Ruetz
2
3 (in-package :eql)
4
5 (defparameter *break-on-errors* nil
6   "Unless NIL, causes a simple (BREAK) on any EQL error.")
7
8 (defmacro alias (s1 s2)
9   `(setf (symbol-function ',s1) (function ,s2)))
10
11 (defmacro qlet ((&rest pairs) &body body)
12   "args: (((var exp) ...) ...)
13    Similar to <code>let*</code>. Creates temporary Qt objects, deleting them at the end of the <code>qlet</code> body. If <code>exp</code> is a string, it will be substituted with <code>(qnew exp)</code>, optionally including constructor arguments.
14        (qlet ((painter \"QPainter\")) ...)
15        (qlet ((reg-exp \"QRegExp(QString)\" \"^\\\\S+$\")) ...)"
16   (let ((vars (mapcar 'first pairs))
17         (exps (mapcar (lambda (x)
18                         (let ((exp (rest x)))
19                           (if (stringp (first exp))
20                               (apply 'list 'qnew exp)
21                               (first exp))))
22                       pairs)))
23     `(let* ,(mapcar 'list vars exps)
24        (unwind-protect
25             (progn
26               ,@body)
27          ,(if (second vars)
28               `(progn . ,(mapcar (lambda (var) (list 'qdelete var))
29                                  (nreverse vars)))
30               `(qdelete ,(first vars)))))))
31
32 (defmacro defvar-ui (main &rest names)
33   "args: (main-widget &rest variables)
34    This macro simplifies the definition of UI variables:
35        (defvar-ui *main* *line-edit* ...) ; this will expand to:
36        (progn (defvar *line-edit* (qfind-child *main* \"line_edit\")) ...)"
37   `(progn
38      ,@(mapcar (lambda (name)
39                  `(defvar ,name (qfind-child ,main ,(string-downcase (substitute #\_ #\- (string-trim "*" (symbol-name name)))))))
40                names)))
41
42 (defun %get-function (fn pkg)
43   (typecase fn
44     (symbol
45      fn)
46     (function
47      (let ((var (intern (symbol-name (gensym)) pkg)))
48        (setf (symbol-function var) fn)
49        var))))
50
51 (defun %make-vector ()
52   (make-array 0 :adjustable t :fill-pointer t))
53
54 (defun %break (&rest args)
55   (apply 'break args))
56
57 ;;; qt-object
58
59 (defstruct (qt-object (:constructor qt-object (pointer unique id &optional finalize)))
60   (pointer 0 :type integer)
61   (unique 0 :type integer)
62   (id 0 :type fixnum)
63   (finalize nil :type boolean))
64
65 (defun new-qt-object (pointer unique id finalize)
66   (let ((obj (qt-object pointer unique id finalize)))
67     (when finalize
68       (ext:set-finalizer obj 'qdelete))
69     obj))
70
71 (defmethod print-object ((obj qt-object) s)
72   (print-unreadable-object (obj s :type nil :identity nil)
73     (format s "~A 0x~X~A"
74             (qt-object-name obj)
75             (qt-object-pointer obj)
76             (if (qt-object-finalize obj) " GC" ""))))
77
78 (defmacro tr (src &optional con (n -1))
79   "args: (source &optional context plural-number)
80    Macro expanding to <code>qtranslate</code>, which calls <code>QCoreApplication::translate()</code>. Both <code>source</code> and <code>context</code> can be Lisp forms evaluating to constant strings (at compile time).<br>The <code>context</code> argument defaults to the Lisp file name. For the <code>plural-number</code>, see Qt Assistant."
81   ;; see compiler-macro in my_app/tr.lisp
82   (let ((source (ignore-errors (eval src)))
83         (context (ignore-errors (eval con))))
84     `(eql:qtranslate ,(if (stringp context)
85                           context
86                           (if *compile-file-truename* (file-namestring *compile-file-truename*) ""))
87                      ,source
88                      ,n)))
89
90 (defun qset-null (obj)
91   "args: (object)
92    Sets the Qt object pointer to <code>0</code>. This function is called automatically after <code>qdel</code>."
93   (when (qt-object-p obj)
94     (setf (qt-object-pointer obj) 0)))
95
96 (let (home)
97   (defun set-home (path)
98     (setf home path))
99   (defun in-home (file)
100     (concatenate 'string home file)))
101
102 (let (slime-ini)
103   (defun set-slime-ini (path)
104     (setf slime-ini path))
105   (defun in-slime-ini (file)
106     (concatenate 'string slime-ini file)))
107
108 (defun qgui (&optional ev)
109   "args: (&optional process-events)
110    Launches the <code>EQL</code> convenience GUI.<br>If you don't have an interactive environment, you can pass <code>T</code> to run a pseudo Qt event loop. A better option is to start the tool like so:<br><code>eql -qgui</code>, in order to run the Qt event loop natively."
111   (in-package :eql)
112   (load (in-home "gui/gui"))
113   (when ev
114     (loop
115        (qprocess-events)
116        (sleep 0.05))))
117
118 (defun qeql (obj1 obj2)
119   "args: (object1 object2)
120    Returns <code>T</code> for same instances of a Qt class.<br>To test for same Qt classes only, do:
121        (= (qt-object-id object1) (qt-object-id object2))"
122   (and (qt-object-p obj1)
123        (qt-object-p obj2)
124        (= (qt-object-id obj1)
125           (qt-object-id obj2))
126        (= (qt-object-pointer obj1)
127           (qt-object-pointer obj2))))
128
129 (defun qnull-object (obj)
130   "args: (object)
131    Checks for a <code>0</code> Qt object pointer."
132   (when (qt-object-p obj)
133     (zerop (qt-object-pointer obj))))
134
135 (defun qdelete (obj &optional later)
136   (%qdelete obj later))
137
138 (defun qapropos (&optional name class type)
139   (let ((main (%qapropos name class type)))
140     (dolist (sub1 main)
141       (format t "~%~%~A~%" (first sub1))
142       (dolist (sub2 (rest sub1))
143         (format t "~%  ~A~%~%" (first sub2))
144         (dolist (sub3 (rest sub2))
145           (let* ((par (position #\( sub3))
146                  (x (if par
147                         (position #\Space sub3 :end par :from-end t)
148                         (position #\Space sub3))))
149             (format t "    ~A~A~%" (make-string (max 0 (- 15 x))) sub3))))))
150   (terpri)
151   nil)
152
153 (defun qapropos* (&optional name class type)
154   "args: (&optional search-string class-name)
155    Similar to <code>qapropos</code>, returning the results as nested list."
156   (%qapropos name class type))
157
158 (defun qnew-instance (name &rest args)
159   (%qnew-instance name args))
160
161 (defun qinvoke-method (obj slot &rest args)
162   (%qinvoke-method obj nil slot args))
163
164 (defun qinvoke-method* (obj name slot &rest args)
165   "args: (object cast-class-name function-name &rest arguments)
166    alias: qfun*
167    Similar to <code>qinvoke-method</code>, additionally passing a class name, enforcing a cast to that class.
168        (qfun* event \"QKeyEvent\" \"key\")
169        (qfun* graphics-text-item \"QGraphicsItem\" \"setPos\" (list x y)) ; multiple inheritance problem
170        (qfun* *qt-main* :qt \"foo\") ; embedded Qt/C++ (see Qt_EQL)"
171   (%qinvoke-method obj name slot args))
172
173 (defun qconnect (from signal to &optional slot)
174   (%qconnect from signal to slot))
175
176 (defun qdisconnect (from &optional signal to slot)
177   (%qdisconnect from signal to slot))
178
179 (defun qobject-names (&optional type)
180   (%qobject-names type))
181
182 (defun qui-class (file &optional var)
183   (%qui-class file var))
184
185 (defun qmessage-box (x)
186   "args: (x)
187    alias: qmsg
188    Convenience function: a simple message box, converting x to a string if necessary."
189   (qlet ((msg "QMessageBox"
190               "icon" |QMessageBox.Information|
191               "text" (if (stringp x) x (prin1-to-string x))))
192     (dolist (fun '("show" "raise" "exec")) ; "raise" needed in some situations
193       (qfun msg fun))))
194
195 (defun qexec (&optional ms)
196   (%qexec ms))
197
198 (defun qevents ()
199   (qexec 200)
200   #-win32
201   (serve-event:serve-all-events 0.02))
202
203 (let (loaded)
204   (defun qselect (&optional on-selected)
205     "args: ()
206      alias: qsel
207      Allows to select (by clicking) any (child) widget. The variable <code>qsel:*q*</code> is bound to the latest selected widget."
208     (unless loaded
209       (setf loaded t)
210       (load (in-home "src/lisp/qselect")))
211     (%qselect on-selected)))
212
213 (alias qnew  qnew-instance)
214 (alias qdel  qdelete)
215 (alias qget  qproperty)
216 (alias qset  qset-property)
217 (alias qfun  qinvoke-method)
218 (alias qfun* qinvoke-method*)
219 (alias qmsg  qmessage-box)
220 (alias qsel  qselect)
221 (alias qq    qquit)
222
223 ;; add property :function-lambda-list to plist of EQL functions (inspired by ext:function-lambda-list)
224
225 (dolist (el (list (cons 'defvar-ui            '(main-widget &rest variables))
226                   (cons 'in-home              '(file-name))
227                   (cons 'qadd-event-filter    '(object event function))
228                   (cons 'qapropos             '(&optional search-string class-name))
229                   (cons 'qapropos*            '(&optional search-string class-name))
230                   (cons 'qconnect             '(caller signal receiver/function &optional slot))
231                   (cons 'qcopy                '(object))
232                   (cons 'qdelete              '(object))
233                   (cons 'qdel                 '(object))
234                   (cons 'qdisconnect          '(caller &optional signal receiver/function slot))
235                   (cons 'qeql                 '(object1 object2))
236                   (cons 'qescape              '(string))
237                   (cons 'qexec                '(&optional milliseconds))
238                   (cons 'qfind-child          '(object name))
239                   (cons 'qfrom-utf8           '(byte-array))
240                   (cons 'qfun                 '(object function-name &rest arguments))
241                   (cons 'qfun*                '(object cast-class-name function-name &rest arguments))
242                   (cons 'qget                 '(object name))
243                   (cons 'qgui                 '(&optional process-events))
244                   (cons 'qid                  '(class-name))
245                   (cons 'qinvoke-method       '(object function-name &rest arguments))
246                   (cons 'qinvoke-method*      '(object cast-class-name function-name &rest arguments))
247                   (cons 'qload-ui             '(file-name))
248                   (cons 'qlocal8bit           '(string))
249                   (cons 'qmessage-box         '(x))
250                   (cons 'qmsg                 '(x))
251                   (cons 'qnew                 '(class-name &rest arguments/properties))
252                   (cons 'qnew-instance        '(class-name &rest arguments/properties))
253                   (cons 'qnull-object         '(object))
254                   (cons 'qobject-names        '(&optional type))
255                   (cons 'qoverride            '(object name function))
256                   (cons 'qproperty            '(object name))
257                   (cons 'qrequire             '(module))
258                   (cons 'qset-null            '(object))
259                   (cons 'qset                 '(object name value))
260                   (cons 'qset-property        '(object name value))
261                   (cons 'qsingle-shot         '(milliseconds function))
262                   (cons 'qstatic-meta-object  '(class-name))
263                   (cons 'qsuper-class-name    '(class-name))
264                   (cons 'qt-object-id         '(object))
265                   (cons 'qt-object-name       '(object))
266                   (cons 'qt-object-p          '(object))
267                   (cons 'qt-object-pointer    '(object))
268                   (cons 'qt-object-unique     '(object))
269                   (cons 'qui-class            '(file-name &optional object-name))
270                   (cons 'qui-names            '(file-name))
271                   (cons 'qutf8                '(string))
272                   (cons 'tr                   '(source &optional context plural-number))))
273   (setf (get (car el) :function-lambda-list) (cdr el)))
274
275 ;;; The following is taken from "src/lsp/top.lsp" version 11.1.1
276 ;;; added SERVE-EVENT to TPL-READ, in order to process Qt events
277 ;;; (every modification is annotated with "[EQL]")
278
279 (in-package :si)
280
281 #-win32
282 (defun qtop-level ()
283   "Args: ()
284 ECL specific.
285 The top-level loop of ECL. It is called by default when ECL is invoked."
286   (catch *quit-tag*
287     (let* ((*debugger-hook* nil)
288            + ++ +++ - * ** *** / // ///)
289       
290       ;;(in-package "CL-USER") [EQL]
291       (in-package "EQL") ;     [EQL]
292       
293       (unless *lisp-initialized*
294         (process-command-args)
295         (format t "ECL (Embeddable Common-Lisp) ~A" (lisp-implementation-version))
296         (format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@
297 Copyright (C) 1993 Giuseppe Attardi~@
298 Copyright (C) 2000 Juan J. Garcia-Ripoll
299 ECL is free software, and you are welcome to redistribute it~@
300 under certain conditions; see file 'Copyright' for details.")
301         (format *standard-output* "~%Type :h for Help.  ")
302         (setq *lisp-initialized* t))
303       
304       (let ((*tpl-level* -1))
305         (qtpl)) ; [EQL]
306       0)))
307
308 #-win32
309 (defun qtpl (&key ((:commands *tpl-commands*) tpl-commands)
310                  ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
311                  (broken-at nil)
312                  (quiet nil))
313   #-ecl-min
314   (declare (c::policy-debug-ihs-frame))
315   (let* ((*ihs-base* *ihs-top*)
316          (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
317          (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
318          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
319          (*frs-top* (frs-top))
320          (*quit-tags* (cons *quit-tag* *quit-tags*))
321          (*quit-tag* *quit-tags*)       ; any unique new value
322          (*tpl-level* (1+ *tpl-level*))
323          (break-level *break-level*)
324          values)
325     (set-break-env)
326     (set-current-ihs)
327     (flet ((rep ()
328              ;; We let warnings pass by this way "warn" does the
329              ;; work.  It is conventional not to trap anything
330              ;; that is not a SERIOUS-CONDITION. Otherwise we
331              ;; would be interferring the behavior of code that relies
332              ;; on conditions for communication (for instance our compiler)
333              ;; and which expect nothing to happen by default.
334              (handler-bind 
335                  ((serious-condition
336                    (lambda (condition)
337                      (cond ((< break-level 1)
338                             ;; Toplevel should enter the debugger on any condition.
339                             )
340                            (*allow-recursive-debug*
341                             ;; We are told to let the debugger handle this.
342                             )
343                            (t
344                             (format t "~&Debugger received error: ~A~%~
345                                          Error flushed.~%" condition)
346                             (clear-input)
347                             (return-from rep t) ;; go back into the debugger loop.
348                             )
349                            )
350                      )))
351
352                (with-grabbed-console
353                    (unless quiet
354                      (break-where)
355                      (setf quiet t))
356                  (setq - (locally (declare (notinline qtpl-read)) ; [EQL]
357                            (tpl-prompt)
358                            (qtpl-read)) ; [EQL]
359                        values (multiple-value-list
360                                (eval-with-env - *break-env*))
361                        /// // // / / values *** ** ** * * (car /))
362                  (tpl-print values)))))
363           (loop
364            (setq +++ ++ ++ + + -)
365            (when
366                (catch *quit-tag*
367                  (if (zerop break-level)
368                    (with-simple-restart 
369                     (restart-toplevel "Go back to Top-Level REPL.")
370                     (rep))
371                    (with-simple-restart
372                     (restart-debugger "Go back to debugger level ~D." break-level)
373                     (rep)))
374                  nil)
375              (setf quiet nil))))))
376
377 ;; taken from "<ecl-dir>/contrib/serve-event/serve-event.lisp"
378 #-win32
379 (defmacro serve-event:with-fd-handler ((fd direction function) &rest body)
380   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
381    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
382    use, and FUNCTION is the function to call whenever FD is usable."
383   (let ((handler (gensym)))
384     `(let (,handler)
385        (unwind-protect
386             (progn
387               (setf ,handler (serve-event:add-fd-handler ,fd ,direction ,function))
388               ,@body)
389          (when ,handler
390            (serve-event:remove-fd-handler ,handler))))))
391
392 #-win32
393 (defun qtpl-read (&aux (*read-suppress* nil))
394   (finish-output)
395   (serve-event:with-fd-handler ; [EQL]
396       (0 :input (lambda (fd)   ; [EQL]
397                   ;; (loop       [EQL]
398                   (case (peek-char nil *standard-input* nil :EOF)
399                     ((#\))
400                      (warn "Ignoring an unmatched right parenthesis.")
401                      (read-char))
402                     ((#\space #\tab)
403                      (read-char))
404                     ((#\newline #\return)
405                      (read-char)
406                      ;; avoid repeating prompt on successive empty lines:
407                        (let ((command (tpl-make-command :newline "")))
408                          (when command (return-from qtpl-read command))))                   ; [EQL]
409                     (:EOF
410                      (terpri)
411                      (return-from qtpl-read (tpl-make-command :EOF "")))                    ; [EQL]
412                     (#\:
413                      (return-from qtpl-read (tpl-make-command (read-preserving-whitespace)  ; [EQL]
414                                                               (read-line))))
415                     (#\?
416                      (read-char)
417                      (case (peek-char nil *standard-input* nil :EOF)
418                        ((#\space #\tab #\newline #\return :EOF)
419                         (return-from qtpl-read (tpl-make-command :HELP (read-line))))       ; [EQL]
420                        (t
421                         (unread-char #\?)
422                         (return-from qtpl-read (read-preserving-whitespace)))))             ; [EQL]
423                     ;; We use READ-PRESERVING-WHITESPACE because with READ, if an
424                     ;; error happens within the reader, and we perform a ":C" or
425                     ;; (CONTINUE), the reader will wait for an inexistent #\Newline.
426                     (t
427                      (return-from qtpl-read (read))))))                                     ; [EQL]
428     (loop               ; [EQL]
429        (eql:qevents)))) ; [EQL]