Qt_EQL: update docu; example 9: tiny fixes
[eql:eql.git] / src / lisp / ini.lisp
1 ;;; copyright (c) 2010-2011 Polos Ruetz
2
3 (in-package :eql)
4
5 (defmacro alias (s1 s2)
6   `(setf (symbol-function ',s1) (function ,s2)))
7
8 (defmacro qlet ((&rest pairs) &body body)
9   "args: (((var exp) ...) ...)
10    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.
11        (qlet ((painter \"QPainter\")) ...)
12        (qlet ((reg-exp \"QRegExp(QString)\" \"^\\\\S+$\")) ...)"
13   (let ((vars (mapcar 'first pairs))
14         (exps (mapcar (lambda (x)
15                         (let ((exp (rest x)))
16                           (if (stringp (first exp))
17                               (apply 'list 'qnew exp)
18                               (first exp))))
19                       pairs))
20         (x (gensym)))
21     `(let* ,(mapcar 'list vars exps)
22        (unwind-protect
23             (progn
24               ,@body)
25          ,(if (second vars)
26               `(dolist (,x (list ,@(nreverse vars)))
27                  (qdel ,x))
28               `(qdel ,(first vars)))))))
29
30 (defun %get-function (fn pkg)
31   (typecase fn
32     (symbol
33      fn)
34     (function
35      (let ((var (intern (symbol-name (gensym)) pkg)))
36        (setf (symbol-function var) fn)
37        var))))
38
39 (defun %make-vector ()
40   (make-array 0 :adjustable t :fill-pointer t))
41
42 ;;; qt-object
43
44 (defstruct (qt-object (:constructor qt-object (pointer unique id &optional finalize)))
45   (pointer 0 :type integer)
46   (unique 0 :type integer)
47   (id 0 :type fixnum)
48   (finalize nil :type boolean))
49
50 (defun new-qt-object (pointer unique id finalize)
51   (let ((obj (qt-object pointer unique id finalize)))
52     (when finalize
53       (ext:set-finalizer obj #'qdelete))
54     obj))
55
56 (defmethod print-object ((obj qt-object) s)
57   (print-unreadable-object (obj s :type nil :identity nil)
58     (format s "~A 0x~X~A"
59             (qt-object-name obj)
60             (qt-object-pointer obj)
61             (if (qt-object-finalize obj) " GC" ""))))
62
63 (defmacro tr (src &optional con (n -1))
64   "args: (source &optional context n)
65    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, and the <code>n</code> argument is a plural indicator (see Qt Assistant)."
66   ;; see compiler-macro in my_app/tr.lisp
67   (let ((source (ignore-errors (eval src)))
68         (context (ignore-errors (eval con))))
69     `(eql:qtranslate ,(if (stringp context)
70                           context
71                           (if *compile-file-truename* (file-namestring *compile-file-truename*) ""))
72                      ,source
73                      ,n)))
74
75 (defun qset-null (obj)
76   "args: (object)
77    Sets the Qt object pointer to <code>0</code>. This function is called automatically after <code>qdel</code>."
78   (when (qt-object-p obj)
79     (setf (qt-object-pointer obj) 0)))
80
81 (let (home)
82   (defun set-home (path)
83     (setf home path))
84   (defun in-home (file)
85     (concatenate 'string home file)))
86
87 (defun qgui (&optional ev)
88   "args: (&optional process-events)
89    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."
90   (in-package :eql)
91   (load (in-home "gui/gui"))
92   (when ev
93     (loop
94        (qprocess-events)
95        (sleep 0.05))))
96
97 (defun qeql (obj1 obj2)
98   "args: (object1 object2)
99    Returns <code>T</code> for same instances of a Qt class."
100   (and (qt-object-p obj1)
101        (qt-object-p obj2)
102        (= (qt-object-pointer obj1)
103           (qt-object-pointer obj2))))
104
105 (defun qnull-object (obj)
106   "args: (object)
107    Checks for a <code>0</code> Qt object pointer."
108   (when (qt-object-p obj)
109     (zerop (qt-object-pointer obj))))
110
111 (defun qdelete (obj &optional later)
112   (qdelete2 obj later))
113
114 (defun qapropos (&optional name class type)
115   (let ((main (qapropos2 name class type)))
116     (dolist (sub1 main)
117       (format t "~%~%~A~%" (first sub1))
118       (dolist (sub2 (rest sub1))
119         (format t "~%  ~A~%~%" (first sub2))
120         (dolist (sub3 (rest sub2))
121           (let* ((par (position #\( sub3))
122                  (x (if par
123                         (position #\Space sub3 :end par :from-end t)
124                         (position #\Space sub3))))
125             (format t "    ~A~A~%" (make-string (max 0 (- 15 x))) sub3)))))
126     (terpri)))
127
128 (defun qapropos* (&optional name class type)
129   "args: (&optional search class)
130    Similar to <code>qapropos</code>, returning the results as nested list."
131   (qapropos2 name class type))
132
133 (defun qnew-instance (name &rest args)
134   (qnew-instance2 name args))
135
136 (defun qinvoke-method (obj slot &rest args)
137   (qinvoke-method2 obj nil slot args))
138
139 (defun qinvoke-method* (obj name slot &rest args)
140   "args: (object class name &rest arguments)
141    alias: qfun*
142    Similar to <code>qinvoke-method</code>, additionally passing a class name, enforcing a cast to that class.
143        (qfun* event \"QKeyEvent\" \"key\")
144        (qfun* graphics-text-item \"QGraphicsItem\" \"setPos\" (list x y)) ; multiple inheritance problem
145        (qfun* *qt-main* :qt \"foo\") ; embedded Qt/C++ (see Qt_EQL)"
146   (qinvoke-method2 obj name slot args))
147
148 (defun qconnect (from signal to &optional slot)
149   (qconnect2 from signal to slot nil))
150
151 (defun qdisconnect (from signal to &optional slot)
152   (qconnect2 from signal to slot t))
153
154 (defun qobject-names (&optional type)
155   (qobject-names2 type))
156
157 (defun qui-class (file &optional var)
158   (qui-class2 file var))
159
160 (defun qmessage-box (msg)
161   "args: (x)
162    alias: qmsg
163    Convenience function, calling: (converting x to a string if necessary)
164        (qfun \"QMessageBox\" \"information\" nil \"EQL\" x))"
165   (qfun "QMessageBox" "information" nil "EQL" (if (stringp msg) msg (prin1-to-string msg))))
166
167 (defun qevents ()
168   (eql:qprocess-events)
169   #-win32
170   (serve-event:serve-all-events 0.01)
171   (sleep 0.01))
172
173 (alias qnew  qnew-instance)
174 (alias qdel  qdelete)
175 (alias qget  qproperty)
176 (alias qset  qset-property)
177 (alias qfun  qinvoke-method)
178 (alias qfun* qinvoke-method*)
179 (alias qmsg  qmessage-box)
180 (alias qq    qquit)
181
182 (in-package :si)
183
184 ;;; The following is taken from "src/lsp/top.lsp" version 11.1.1
185 ;;; added SERVE-EVENT to TPL-READ, in order to process Qt events
186 ;;; (every modification is annotated with "[EQL]")
187
188 #-win32
189 (defun qtop-level ()
190   "Args: ()
191 ECL specific.
192 The top-level loop of ECL. It is called by default when ECL is invoked."
193   (catch *quit-tag*
194     (let* ((*debugger-hook* nil)
195            + ++ +++ - * ** *** / // ///)
196       
197       ;;(in-package "CL-USER") [EQL]
198       (in-package "EQL") ;     [EQL]
199       
200       (unless *lisp-initialized*
201         (process-command-args)
202         (format t "ECL (Embeddable Common-Lisp) ~A" (lisp-implementation-version))
203         (format t "~%Copyright (C) 1984 Taiichi Yuasa and Masami Hagiya~@
204 Copyright (C) 1993 Giuseppe Attardi~@
205 Copyright (C) 2000 Juan J. Garcia-Ripoll
206 ECL is free software, and you are welcome to redistribute it~@
207 under certain conditions; see file 'Copyright' for details.")
208         (format *standard-output* "~%Type :h for Help.  ")
209         (setq *lisp-initialized* t))
210       
211       (let ((*tpl-level* -1))
212         (qtpl)) ; [EQL]
213       0)))
214
215 #-win32
216 (defun qtpl (&key ((:commands *tpl-commands*) tpl-commands)
217                  ((:prompt-hook *tpl-prompt-hook*) *tpl-prompt-hook*)
218                  (broken-at nil)
219                  (quiet nil))
220   #-ecl-min
221   (declare (c::policy-debug-ihs-frame))
222   (let* ((*ihs-base* *ihs-top*)
223          (*ihs-top* (if broken-at (ihs-search t broken-at) (ihs-top)))
224          (*ihs-current* (if broken-at (ihs-prev *ihs-top*) *ihs-top*))
225          (*frs-base* (or (sch-frs-base *frs-top* *ihs-base*) (1+ (frs-top))))
226          (*frs-top* (frs-top))
227          (*quit-tags* (cons *quit-tag* *quit-tags*))
228          (*quit-tag* *quit-tags*)       ; any unique new value
229          (*tpl-level* (1+ *tpl-level*))
230          (break-level *break-level*)
231          values)
232     (set-break-env)
233     (set-current-ihs)
234     (flet ((rep ()
235              ;; We let warnings pass by this way "warn" does the
236              ;; work.  It is conventional not to trap anything
237              ;; that is not a SERIOUS-CONDITION. Otherwise we
238              ;; would be interferring the behavior of code that relies
239              ;; on conditions for communication (for instance our compiler)
240              ;; and which expect nothing to happen by default.
241              (handler-bind 
242                  ((serious-condition
243                    (lambda (condition)
244                      (cond ((< break-level 1)
245                             ;; Toplevel should enter the debugger on any condition.
246                             )
247                            (*allow-recursive-debug*
248                             ;; We are told to let the debugger handle this.
249                             )
250                            (t
251                             (format t "~&Debugger received error: ~A~%~
252                                          Error flushed.~%" condition)
253                             (clear-input)
254                             (return-from rep t) ;; go back into the debugger loop.
255                             )
256                            )
257                      )))
258
259                (with-grabbed-console
260                    (unless quiet
261                      (break-where)
262                      (setf quiet t))
263                  (setq - (locally (declare (notinline qtpl-read)) ; [EQL]
264                            (tpl-prompt)
265                            (qtpl-read)) ; [EQL]
266                        values (multiple-value-list
267                                (eval-with-env - *break-env*))
268                        /// // // / / values *** ** ** * * (car /))
269                  (tpl-print values)))))
270           (loop
271            (setq +++ ++ ++ + + -)
272            (when
273                (catch *quit-tag*
274                  (if (zerop break-level)
275                    (with-simple-restart 
276                     (restart-toplevel "Go back to Top-Level REPL.")
277                     (rep))
278                    (with-simple-restart
279                     (restart-debugger "Go back to debugger level ~D." break-level)
280                     (rep)))
281                  nil)
282              (setf quiet nil))))))
283
284 ;; taken from "<ecl-dir>/contrib/serve-event/serve-event.lisp"
285 #-win32
286 (defmacro serve-event:with-fd-handler ((fd direction function) &rest body)
287   "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
288    DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
289    use, and FUNCTION is the function to call whenever FD is usable."
290   (let ((handler (gensym)))
291     `(let (,handler)
292        (unwind-protect
293             (progn
294               (setf ,handler (serve-event:add-fd-handler ,fd ,direction ,function))
295               ,@body)
296          (when ,handler
297            (serve-event:remove-fd-handler ,handler))))))
298
299 #-win32
300 (defun qtpl-read (&aux (*read-suppress* nil))
301   (finish-output)
302   (serve-event:with-fd-handler ; [EQL]
303       (0 :input (lambda (fd)   ; [EQL]
304                   ;; (loop       [EQL]
305                   (case (peek-char nil *standard-input* nil :EOF)
306                     ((#\))
307                      (warn "Ignoring an unmatched right parenthesis.")
308                      (read-char))
309                     ((#\space #\tab)
310                      (read-char))
311                     ((#\newline #\return)
312                      (read-char)
313                      ;; avoid repeating prompt on successive empty lines:
314                        (let ((command (tpl-make-command :newline "")))
315                          (when command (return-from qtpl-read command))))                   ; [EQL]
316                     (:EOF
317                      (terpri)
318                      (return-from qtpl-read (tpl-make-command :EOF "")))                    ; [EQL]
319                     (#\:
320                      (return-from qtpl-read (tpl-make-command (read-preserving-whitespace)  ; [EQL]
321                                                               (read-line))))
322                     (#\?
323                      (read-char)
324                      (case (peek-char nil *standard-input* nil :EOF)
325                        ((#\space #\tab #\newline #\return :EOF)
326                         (return-from qtpl-read (tpl-make-command :HELP (read-line))))       ; [EQL]
327                        (t
328                         (unread-char #\?)
329                         (return-from qtpl-read (read-preserving-whitespace)))))             ; [EQL]
330                     ;; We use READ-PRESERVING-WHITESPACE because with READ, if an
331                     ;; error happens within the reader, and we perform a ":C" or
332                     ;; (CONTINUE), the reader will wait for an inexistent #\Newline.
333                     (t
334                      (return-from qtpl-read (read))))))                                     ; [EQL]
335     (loop               ; [EQL]
336        (eql:qevents)))) ; [EQL]