add GC for QGET, QFUN return values; fix possible memory leaks (e.g. overridden metho...
[eql:eql.git] / examples / 9-simple-lisp-editor / editor.lisp
1 ;;; copyright (c) 2010-2011 Polos Ruetz
2 ;;;
3 ;;; A very basic and experimental(!) Lisp editor, featuring:
4 ;;;
5 ;;;   - a popup completer (for EQL functions only)
6 ;;;   - paren highlighting
7 ;;;   - simple auto indent, indent parapgraph
8 ;;;   - simple syntax highlighter
9 ;;;
10 ;;;   - an independent local Lisp server process for evaluation
11 ;;;   - native Qt event processing through QApplication::exec()
12 ;;;   - eval region
13
14 (require :local-client (probe-file "local-client.lisp"))
15 (require :settings     (probe-file "settings.lisp"))
16
17 (defpackage :editor
18   (:use :common-lisp :eql)
19   (:export
20    #:start))
21
22 (in-package :editor)
23
24 (defun os-pathname (name)
25   #+(or darwin linux)
26   (qutf8 name)
27   #+win32
28   (qlocal8bit name))
29
30 (defun read-file (file &optional (set-name t))
31   (with-open-file (s (os-pathname file) :direction :input)
32     (when set-name
33       (setf *file-name* file))
34     (let ((str (make-string (file-length s))))
35       (read-sequence str s)
36       str)))
37
38 (defun from-file (name)
39   (eval (read-from-string (read-file name nil))))
40
41 (defparameter *auto-indent*   (from-file "data/auto-indent.lisp"))
42 (defparameter *eql-keywords*  (from-file "data/eql-keywords.lisp"))
43 (defparameter *lisp-keywords* (from-file "data/lisp-keywords.lisp"))
44
45 (defparameter *current-completer*      nil)
46 (defparameter *current-depth*          0)
47 (defparameter *current-keyword-indent* 0)
48 (defparameter *cursor-code-depth*      0)
49 (defparameter *error-region*           nil)
50 (defparameter *extra-selections*       nil)
51 (defparameter *file-name*              nil)
52 (defparameter *keep-extra-selections*  nil)
53 (defparameter *latest-eval-position*   nil)
54 (defparameter *try-read-error*         nil)
55
56 (defconstant +max-shown-completions+ 10)
57 (defconstant +max-history+           50)
58 (defconstant +package-char-dummy+    #\$)
59 (defconstant +history-file+          ".command-history")
60
61 ;;; Qt
62
63 (defvar *main*                (qload-ui "data/editor.ui"))
64 (defvar *editor*              (qfind-child *main* "editor"))
65 (defvar *output*              (qfind-child *main* "output"))
66 (defvar *command*             (qfind-child *main* "command"))
67 (defvar *splitter*            (qfind-child *main* "splitter"))
68 (defvar *find*                (qfind-child *main* "find"))
69 (defvar *replace*             (qfind-child *main* "replace"))
70 (defvar *next-button*         (qfind-child *main* "next_button"))
71 (defvar *replace-button*      (qfind-child *main* "replace_button"))
72 (defvar *action-open*         (qfind-child *main* "action_open"))
73 (defvar *action-save*         (qfind-child *main* "action_save"))
74 (defvar *action-save-as*      (qfind-child *main* "action_save_as"))
75 (defvar *action-save-and-run* (qfind-child *main* "action_save_and_run"))
76 (defvar *action-eval-region*  (qfind-child *main* "action_eval_region"))
77 (defvar *action-repeat-eval*  (qfind-child *main* "action_repeat_eval"))
78
79 (defparameter *current-editor*       *editor*)
80 (defparameter *lisp-match-rule*      nil)
81 (defparameter *eql-keyword-format*   nil)
82 (defparameter *lisp-keyword-format*  nil)
83 (defparameter *comment-format*       nil)
84 (defparameter *parenthesis-color*    "gray")
85 (defparameter *string-color*         "sienna")
86 (defparameter *completer*            nil)
87
88 (defun file-open (&optional name)
89   (unless name
90     (setf name (qfun "QFileDialog" "getOpenFileName" nil "" "" "Lisp files (*.lisp)")))
91   (unless (x:empty-string name)
92     (file-save)
93     (qset *editor* "plainText" (read-file name))
94     (show-file-name)))
95
96 (defun save-file (name)
97   (when (and (stringp name)
98              (not (x:empty-string name)))
99     (with-open-file (s (os-pathname name) :direction :output
100                        :if-exists :supersede)
101       (write-string (qget *editor* "plainText") s)
102       (setf *file-name* name)
103       (show-file-name))))
104
105 (defun file-save ()
106   (save-file *file-name*))
107
108 (defun file-save-as ()
109   (let ((name (qfun "QFileDialog" "getSaveFileName" nil "" "" "Lisp files (*.lisp)")))
110     (unless (x:ends-with ".lisp" name)
111       (setf name (concatenate 'string name ".lisp")))
112     (save-file name)))
113
114 (defun show-file-name ()
115   (qset *main* "windowTitle" (file-namestring *file-name*)))
116
117 (defun ini ()
118   (flet ((keys (str)
119            (qnew "QKeySequence(QString)" str)))
120     (setf *eql-keyword-format*  (qnew "QTextCharFormat")
121           *lisp-keyword-format* (qnew "QTextCharFormat")
122           *comment-format*      (qnew "QTextCharFormat")
123           *completer*           (qnew "QListWidget"
124                                       "horizontalScrollBarPolicy" |Qt.ScrollBarAlwaysOff|
125                                       "verticalScrollBarPolicy" |Qt.ScrollBarAlwaysOff|))
126     (let ((editor-highlighter  (qnew "QSyntaxHighlighter(QTextDocument*)" (qfun *editor* "document")))
127           (command-highlighter (qnew "QSyntaxHighlighter(QTextDocument*)" (qfun *command* "document"))))
128       (qset *action-open*         "shortcut" (keys "Ctrl+O"))
129       (qset *action-save*         "shortcut" (keys "Ctrl+S"))
130       (qset *action-save-and-run* "shortcut" (keys "Ctrl+R"))
131       (qset *action-eval-region*  "shortcut" (keys "Ctrl+Return"))
132       (qset *action-repeat-eval*  "shortcut" (keys "Ctrl+E"))
133       (dolist (w (list *editor* *output* *command*))
134         (qset w "font" eql::*code-font*))
135       (x:do-with (qset *output*)
136         ("readOnly" t)
137         ("tabStopWidth" (* 8 (first (font-metrics-size)))))
138       (x:do-with (qset *completer*)
139         ("font" eql::*code-font*)
140         ("frameShape" |QFrame.Box|)
141         ("frameShadow" |QFrame.Plain|)
142         ("lineWidth" 1))
143       (x:do-with (qset *main*)
144         ("size" (list 800 500))
145         ("windowTitle" "Simple Lisp Editor"))
146       (x:do-with (qset *command*)
147         ("horizontalScrollBarPolicy" |Qt.ScrollBarAlwaysOff|)
148         ("verticalScrollBarPolicy" |Qt.ScrollBarAlwaysOff|))
149       (qfun *command* "setFixedHeight" (+ (second (font-metrics-size))
150                                           (* 2 (qget *command* "frameWidth"))))
151       (x:do-with (qfun *splitter* "setStretchFactor")
152         (0 2)
153         (1 1))
154       (set-color *output* |QPalette.Base| "lavender")
155       (qfun *completer* "setWindowFlags" |Qt.Popup|)
156       (dolist (ed (list *editor* *command*))
157         (qconnect ed  "cursorPositionChanged()" 'cursor-position-changed))
158       (qconnect *completer* "itemDoubleClicked(QListWidgetItem*)" 'insert-completer-option-text)
159       (qconnect *find* "returnPressed()" 'find-text)
160       (qconnect *next-button* "clicked()" 'find-text)
161       (qconnect *replace* "returnPressed()" 'replace-text)
162       (qconnect *replace-button* "clicked()" 'replace-text)
163       (qconnect *action-open* "triggered()" 'file-open)
164       (qconnect *action-save* "triggered()" 'file-save)
165       (qconnect *action-save-as* "triggered()" 'file-save-as)
166       (qconnect *action-save-and-run* "triggered()" 'save-and-run)
167       (qconnect *action-eval-region* "triggered()" 'eval-region)
168       (qconnect *action-repeat-eval* "triggered()" 'repeat-eval)
169       (qconnect (qapp) "aboutToQuit()" 'clean-up)
170       (qoverride *editor* "keyPressEvent(QKeyEvent*)" 'editor-key-pressed)
171       (qoverride *completer* "keyPressEvent(QKeyEvent*)" 'completer-key-pressed)
172       (qoverride *completer* "focusOutEvent(QFocusEvent*)" 'close-completer)
173       (qoverride editor-highlighter  "highlightBlock(QString)" (lambda (str) (highlight-block editor-highlighter str)))
174       (qoverride command-highlighter "highlightBlock(QString)" (lambda (str) (highlight-block command-highlighter str)))
175       (qoverride *command* "keyPressEvent(QKeyEvent*)" 'command-key-pressed)
176       (show-status-message (format nil (tr "<b style='color:#4040E0'>Eval Region:</b> move to paren <b>(</b> or <b>)</b>, hit <b>~A</b>")
177                                    (qfun (qget *action-eval-region* "shortcut") "toString" |QKeySequence.NativeText|))
178                            :html)
179       (ini-highlight-rules)
180       (local-client:ini 'data-from-server)
181       (qfun *main* "show"))))
182
183 (defun clean-up ()
184   (file-save))
185
186 (defun document ()
187   (qfun *current-editor* "document"))
188
189 (defun font-metrics-size ()
190   (qlet ((fm "QFontMetrics(QFont)" eql::*code-font*))
191     (list (qfun fm "width(QChar)" #\Space)
192           (qfun fm "height"))))
193
194 (defun set-color (widget role color)
195   (let ((pal (qget widget "palette")))
196     (qfun pal "setColor(QPalette::ColorRole,QColor)" role color)
197     (qset widget "palette" pal)))
198
199 (let (label)
200   (defun show-status-message (msg &optional html)
201     (let ((bar (qfun *main* "statusBar")))
202       (when (and html (not label))
203         (qfun bar "addWidget" (setf label (qnew "QLabel")) 1))
204       (if html
205           (qset label "text" msg)
206           (qfun bar "showMessage" msg)))))
207
208 (defun ini-highlight-rules ()
209   (x:do-with (qfun *eql-keyword-format*)
210     ("setForeground" (qnew "QBrush(QColor)" "#2020D0"))
211     ("setFontWeight" |QFont.Bold|))
212   (x:do-with (qfun *lisp-keyword-format*)
213     ("setForeground" (qnew "QBrush(QColor)" "#D02020"))
214     ("setFontWeight" |QFont.Bold|))
215   (x:do-with (qfun *comment-format*)
216     ("setForeground" (qnew "QBrush(QColor)" "#208080"))
217     ("setFontItalic" t))
218   (setf *lisp-match-rule* (qnew "QRegExp(QString)" "[(']:*[^ )]+")))
219
220 (defun read* (str &optional (start 0))
221   (setf *try-read-error* nil)
222   (let ((*package* #.(find-package :eql)))
223     (multiple-value-bind (exp x)
224         (ignore-errors (read-from-string (substitute +package-char-dummy+ #\: str)
225                                          nil nil :start start :preserve-whitespace t))
226       (unless exp
227         (setf *try-read-error* (typecase x
228                                  (end-of-file :end-of-file)
229                                  (t t))))
230       (values exp x))))
231
232 (defun end-position (expr)
233   (multiple-value-bind (x end)
234       (read* expr)
235     (when (numberp end)
236       end)))
237
238 (defun text-until-cursor (text-cursor text-block)
239   (subseq (qfun text-block "text") 0 (- (qfun text-cursor "position")
240                                         (qfun text-block "position"))))
241
242 (defun insert-text (text &optional select)
243   (let* ((text-cursor (qfun *current-editor* "textCursor"))
244          (text-block (qfun text-cursor "block"))
245          (text* (text-until-cursor text-cursor text-block))
246          (p (position #\" text* :from-end t)))
247     (when (and select
248                (not (x:ends-with "\"" text*)))
249       (qfun text-cursor "movePosition" |QTextCursor.Left| |QTextCursor.KeepAnchor| (1- (- (length text*) p))))
250     (qfun text-cursor "insertText" text)
251     (qfun *current-editor* "setTextCursor" text-cursor)))
252
253 (defun constructor-args (name)
254   (sort (mapcar #'(lambda (el)
255                     (subseq el (position #\( el)))
256                 (cdadar (qapropos* "constructor" name)))
257         'string<))
258
259 (defun fun-args (fun)
260   (subseq fun (1+ (position #\( fun)) (position #\) fun :from-end t)))
261
262 (defun call-candidates (name type &optional args (const t) static)
263   (let ((types (case type
264                  (:properties
265                     '("Properties:"))
266                  (:functions
267                     (if static '("Methods:") '("Methods:" "Slots:" "Signals:")))
268                  (:signals
269                     '("Signals:"))
270                  (:slots
271                     '("Slots:"))
272                  (:override
273                     '("Override:"))))
274         candidates)
275     (do ((curr name (qsuper-class-name curr)))
276         ((null curr))
277       (let ((all (cdar (qapropos* nil curr))))
278         (flet ((add (x)
279                  (dolist (fun (rest (find x all :test 'string= :key 'first)))
280                    (if (eql :properties type)
281                        (when (or const (not (x:ends-with " const" fun)))
282                          (let* ((start (1+ (position #\Space fun)))
283                                 (end (position #\Space fun :start start)))
284                            (push (subseq fun start (if end end (length fun)))
285                                  candidates)))
286                        (let ((static* (x:ends-with "static" fun)))
287                          (when (if args
288                                    (x:starts-with (fun-args fun) args)
289                                    (if static
290                                        static*
291                                        (and (not (or static*
292                                                      (x:starts-with "constructor" fun))))))
293                            (let ((fun* (subseq fun (1+ (position #\Space fun :end (position #\( fun) :from-end t)))))
294                              (push (if static
295                                        (subseq fun* 0 (- (length fun*) 7))
296                                        fun*)
297                                    candidates))))))))
298           (dolist (x types)
299             (add x)))))
300     (sort candidates 'string<)))
301
302 (defun cut-optional-type-list (fun-name)
303   (flet ((arg-count (x)
304            (if (x:ends-with "()" x)
305                0
306                (1+ (count #\, x)))))
307     (let ((no-types (subseq fun-name 0 (position #\( fun-name)))
308           (num-args* (arg-count fun-name)))
309       (dolist (name (mapcar (lambda (item)
310                               (qfun item "text"))
311                             (qfun *completer* "findItems"
312                                   (format nil "~A(" no-types) (logior |Qt.MatchStartsWith| |Qt.MatchCaseSensitive|))))
313         (when (string/= fun-name name)
314           (let ((num-args (arg-count name)))
315             (when (= num-args* num-args)
316               (return-from cut-optional-type-list fun-name)))))
317       no-types)))
318
319 (defun global-var-name-p (var)
320   (let ((name (symbol-name var)))
321     (flet ((enclosed (ch)
322              (and (x:starts-with ch name)
323                   (x:ends-with ch name))))
324       (or (enclosed "*")
325           (enclosed "+")))))
326
327 (let (qt-matches cache-matches)
328   (flet ((qt-fun (pos)
329            (cdr (assoc (- pos 2) qt-matches)))
330          (qt-pos (fun)
331            (car (find fun qt-matches :key 'cdr))))
332     (defun highlight-block (highlighter text)
333       (unless (x:empty-string text)
334         (when cache-matches
335           (setf qt-matches nil))
336         (let ((i (qfun *lisp-match-rule* "indexIn" text)))
337           (x:while (>= i 0)
338             (let* ((len (qfun *lisp-match-rule* "matchedLength"))
339                    (kw* (subseq text (1+ i) (+ i len)))
340                    (kw (x:if-it (position #\: kw* :from-end t)
341                            (subseq kw* (1+ x:it))
342                            kw*)))
343               (flet ((set-format (frm)
344                        (qfun highlighter "setFormat(int,int,QTextCharFormat)" (1+ i) (1- len) frm)))
345                 (cond ((find kw *eql-keywords* :test 'string=)
346                        (when cache-matches
347                          (push (cons (+ i len) (intern (string-upcase kw) :keyword))
348                                qt-matches))
349                        (set-format *eql-keyword-format*))
350                       ((gethash kw *lisp-keywords*)
351                        (set-format *lisp-keyword-format*))))
352               (setf i (qfun *lisp-match-rule* "indexIn" text (+ i len))))))
353         (setf cache-matches nil)
354         ;; comments, strings, parenthesis
355         (flet ((set-color (pos len color)
356                  (qfun highlighter "setFormat(int,int,QColor)" pos len color)))
357           (let ((ex #\Space))
358             (dotimes (i (length text))
359               (let ((ch (char text i)))
360                 (unless (char= #\\ ex)
361                   (case ch
362                     ((#\( #\))
363                        (set-color i 1 *parenthesis-color*))
364                     (#\"
365                        (x:when-it (end-position (subseq text i))
366                          (set-color i x:it *string-color*)
367                          (incf i (1- x:it))))
368                     (#\;
369                        (qfun highlighter "setFormat(int,int,QTextCharFormat)" i (- (length text) i) *comment-format*)
370                        (return))))
371                 (setf ex ch)))))))
372     (defun cursor-position-changed ()
373       (setf *current-editor* (qsender))
374       (setf cache-matches t)
375       (when (and *extra-selections*
376                  (not *keep-extra-selections*))
377         (setf *extra-selections* nil
378               *error-region* nil)
379         (qfun *current-editor* "setExtraSelections" nil))
380       (setf *current-depth* 0
381             *current-keyword-indent* 0)
382       (let* ((text-cursor (qfun *current-editor* "textCursor"))
383              (text-block (qfun text-cursor "block"))
384              (line (qfun text-block "text"))
385              (pos (qfun text-cursor "columnNumber")))
386         (when (and (plusp (length line))
387                    (< pos (length line))
388                    (char= #\( (char line pos))
389                    (or (zerop pos)
390                        (char/= #\\ (char line (1- pos)))))
391           (let ((pos* pos))
392             (when (and (plusp pos)
393                        (char= #\` (char line (1- pos)))) ; macros etc.
394               (decf pos*))
395             (show-matching-parenthesis text-cursor (subseq line pos*) :left pos*)))
396         (unless (zerop pos)
397           (let ((pos-char (char line (1- pos))))
398             (if *current-completer*
399                 (if (char= #\Space pos-char)
400                     (close-completer)
401                     (x:when-it (position #\" line :end pos :from-end t)
402                       (let* ((begin (subseq line (1+ x:it) pos))
403                              (item (first (qfun *completer* "findItems"
404                                                 begin (logior |Qt.MatchStartsWith| |Qt.MatchCaseSensitive|)))))
405                         (if item
406                             (set-current-item item begin)
407                             (qfun *completer* "clearSelection")))))
408                 (let ((fun (qt-fun pos)))
409                   (if (find fun '(:qnew :qfun))
410                       ;; show object name completer?
411                       (when (char= #\" pos-char)
412                         (completer (qobject-names) (if (eql :qnew fun) :qnew :qfun-static))
413                         (return-from cursor-position-changed))
414                       (flet ((ending (start)
415                                (if (< start pos)
416                                    (subseq line start pos)
417                                    ""))
418                              (var (str &optional (n 1))
419                                (let ((start 0)
420                                      var)
421                                  (dotimes (i n)
422                                    (multiple-value-setq (var start)
423                                      (read* str start)))
424                                  var))
425                              (type (var)
426                                (let ((global (global-var-name-p var)))
427                                  (find-in-source var
428                                                  (current-source-code text-cursor (subseq line 0 pos) (when global :all))
429                                                  global))))
430                         (case pos-char
431                           (#\(
432                            (cond ((x:when-it (qt-pos :qnew)
433                                     ;; show QNEW constructor completer?
434                                     (when (> pos x:it)
435                                       (x:when-it* (position #\Q line :start x:it)
436                                         (let ((qt-name (subseq line x:it* (1- pos))))
437                                           (when (qid qt-name)
438                                             (completer (constructor-args qt-name) :qnew-constructor)
439                                             (return-from cursor-position-changed)))))))
440                                  ((x:when-it (search " \"Q" line :test 'string= :end2 pos)
441                                     ;; show QLET constructor completer?
442                                     (let ((qt-name (read* (format nil "~A\"" (subseq line x:it (1- pos))))))
443                                       (when (and (stringp qt-name)
444                                                  (qid qt-name))
445                                         (completer (constructor-args qt-name) :qnew-constructor)
446                                         (return-from cursor-position-changed)))))))
447                           (#\)
448                            (show-matching-parenthesis text-cursor (subseq line 0 pos) :right))
449                           (#\"
450                            (let* ((qget (qt-pos :qget))
451                                   (qset (unless qget (qt-pos :qset))))
452                              (cond ((or qget qset)
453                                     (let* ((ending (ending (or qget qset)))
454                                            (var (var ending)))
455                                       (when (= 1 (count #\" ending))
456                                         ;; show QGET or QSET completer?
457                                         (when var
458                                           (let ((global (global-var-name-p var)))
459                                             (x:when-it (type var)
460                                               (completer (call-candidates x:it :properties nil qget) :qget)
461                                               (return-from cursor-position-changed)))))))
462                                    ((x:when-it (qt-pos :qfun)
463                                       (let* ((ending (ending x:it))
464                                              (var (var ending)))
465                                         (case (count #\" ending)
466                                           (1
467                                            ;; show QFUN completer?
468                                            (when var
469                                              (let ((global (global-var-name-p var)))
470                                                (x:when-it* (type var)
471                                                  (completer (call-candidates x:it* :functions) :qfun)
472                                                  (return-from cursor-position-changed)))))
473                                           (3
474                                            ;; show QFUN completer for static functions?
475                                            (when (qid var)
476                                              (completer (call-candidates var :functions nil t :static) :qfun)
477                                              (return-from cursor-position-changed)))))))
478                                    ((x:when-it (qt-pos :qconnect)
479                                       (let ((ending (ending x:it)))
480                                         (case (count #\" ending)
481                                           (1
482                                            ;; show QCONNECT-FROM completer?
483                                            (let ((var (var ending)))
484                                              (when var
485                                                (let ((global (global-var-name-p var)))
486                                                  (x:when-it* (type var)
487                                                    (completer (call-candidates x:it* :signals) :qconnect-from)
488                                                    (return-from cursor-position-changed))))))
489                                           (3
490                                            ;; show QCONNECT-TO completer?
491                                            (let ((sig (var ending 2))
492                                                  (var (var ending 3)))
493                                              (when (and (stringp sig)
494                                                         var)
495                                                (let ((global (global-var-name-p var)))
496                                                  (x:when-it* (type var)
497                                                    (completer (call-candidates x:it* :slots (fun-args sig))
498                                                               :qconnect-to)
499                                                    (return-from cursor-position-changed))))))))))
500                                    ((x:when-it (qt-pos :qoverride)
501                                       ;; show QOVERRIDE completer?
502                                       (let* ((ending (ending x:it))
503                                              (var (var ending)))
504                                         (when (and var (= 1 (count #\" ending)))
505                                           (let ((global (global-var-name-p var)))
506                                             (x:when-it* (type var)
507                                               (completer (call-candidates x:it* :override) :qoverride)
508                                               (return-from cursor-position-changed)))))))
509                                    ((x:when-it (qt-pos :qfind-child)
510                                       ;; show QFIND-CHILD completer?
511                                       (let* ((ending (ending x:it))
512                                              (var (var ending)))
513                                         (when (= 1 (count #\" ending))
514                                           (let* ((global (global-var-name-p var))
515                                                  (exp (find-in-source var
516                                                                       (current-source-code text-cursor (subseq line 0 pos) :all)
517                                                                       global
518                                                                       :exp))
519                                                  (ui-name (ignore-errors
520                                                             (eval (second (if global (third exp) exp))))))
521                                             (x:when-it* (qui-names ui-name)
522                                               (completer (sort x:it* 'string<) :qfind-child)
523                                               (return-from cursor-position-changed)))))))
524                                    (t
525                                     ;; show QLET object name completer?
526                                     (when (var-in-qlet-tree-p (current-source-code text-cursor (subseq line 0 pos)))
527                                       (completer (qobject-names) :qnew)
528                                       (return-from cursor-position-changed)))))))))))))))))
529
530 (defun insert-completer-option-text (&optional item)
531   (qfun *completer* "resize" '(0 0))
532   (flet ((add-quote (x)
533            (format nil "~A\"" x)))
534     (x:when-it (current-completer-option)
535       (case *current-completer*
536         (:qnew
537            (insert-text x:it :select))
538         (:qnew-constructor
539            (insert-text (add-quote (subseq x:it 1))))
540         (:qfun
541            (insert-text (add-quote (cut-optional-type-list x:it)) :select))
542         ((:qget :qset :qfun-static :qfind-child :qconnect-from :qconnect-to :qoverride)
543            (insert-text (add-quote x:it) :select)))))
544   (close-completer))
545
546 (defun completer-key-pressed (key-event)
547   (when *current-completer*
548     (flet ((leave ()
549              (return-from completer-key-pressed t)))
550       (let ((forward t))
551         (case (qfun key-event "key")
552           ((#.|Qt.Key_Up| #.|Qt.Key_Down| #.|Qt.Key_PageUp| #.|Qt.Key_PageDown| #.|Qt.Key_Home| #.|Qt.Key_End|)
553              (setf forward nil))
554           (#.|Qt.Key_Return|
555              (insert-completer-option-text)
556              (leave))
557           (#.|Qt.Key_Escape|
558              (close-completer)
559              (leave)))
560         (when forward
561           (qfun "QCoreApplication" "sendEvent" *current-editor* key-event)
562           t)))))
563
564 (defun current-completer-option ()
565   (qfun (first (qfun *completer* "selectedItems")) "text"))
566
567 (let (cursor-pos height)
568   (defun completer (options name)
569     (setf *current-completer* name)
570     (unless (null options)
571       (x:do-with (qfun *completer*)
572         "clear"
573         ("addItems" options)
574         "adjustSize")
575       (let ((fm-size (font-metrics-size)))
576         (setf height (second fm-size))
577         (qset *completer* "size"
578               (list (+ 15 (* (min 80 (apply 'max (mapcar 'length options)))
579                              (first fm-size)))
580                     (+ 2 (* (min +max-shown-completions+ (length options)) height)))))
581       (set-current-item (qfun *completer* "item" 0))
582       (adjust-completer-pos :ini)
583       (x:do-with (qfun *completer*)
584         "show"
585         "setFocus")))
586   (defun adjust-completer-pos (&optional ini)
587     (let* ((desktop (qfun (qfun "QApplication" "desktop") "availableGeometry"))
588            (cursor (if ini
589                        (setf cursor-rect (qfun *current-editor* "cursorRect"))
590                        cursor-rect))
591            (pos (qfun (qfun *current-editor* "viewport") "mapToGlobal"
592                       (list (+ (first cursor) (third cursor))
593                             (+ (second cursor) (fourth cursor)))))
594            (size (qget *completer* "size"))
595            (dx (- (+ (first pos) (first size))
596                   (third desktop)))
597            (dy (- (+ (second pos) (second size))
598                   (fourth desktop))))
599       (when (plusp dx)
600         (decf (first pos) dx))
601       (when (plusp dy)
602         (decf (second pos) (+ (fourth cursor) (second size))))
603       (qset *completer* "pos" pos)))
604   (defun set-current-item (item &optional begin)
605     (when begin
606       (do ((row (qfun *completer* "row" item) (1+ row))
607            (n-shown 0 (1+ n-shown)))
608           ((or (= row (qfun *completer* "count"))
609                (= +max-shown-completions+ n-shown)
610                (not (x:starts-with begin (qfun (qfun *completer* "item" row) "text"))))
611              (qset *completer* "size" (list (qget *completer* "width")
612                                             (+ 2 (* n-shown height))))
613              (adjust-completer-pos))))
614     (qfun item "setSelected" t)
615     (x:do-with (qfun *completer*)
616       ("scrollToItem" item |QAbstractItemView.PositionAtTop|)
617       ("setCurrentItem" item))))
618
619 (defun close-completer (&optional event)
620   (setf *current-completer* nil)
621   (x:do-with (qfun *completer*)
622     "hide"
623     "clear")
624   (qfun *current-editor* "setFocus"))
625
626 (defun current-source-code (text-cursor &optional curr-line all)
627   (let ((lines (when curr-line (list curr-line))))
628     (do ((n (- (qfun text-cursor "blockNumber") (if curr-line 1 0)) (1- n)))
629         ((minusp n))
630       (let* ((text-block (qfun (document) "findBlockByNumber" n))
631              (text (qfun text-block "text")))
632         (push text lines)
633         (when (and (not all)
634                    (x:starts-with "(" text))
635           (return))))
636     (push "(" lines)
637     (code-tree (with-output-to-string (s)
638                  (dolist (line lines)
639                    (write-line line s))))))
640
641 (defun code-tree (str)
642   (let ((tree (read* (concatenate 'string
643                                   (string-right-trim '(#\Newline #\Space #\") str)
644                                   #.(make-string 99 :initial-element #\))))))
645     (do ((exp tree (first (last exp)))
646          (depth -1 (1+ depth)))
647         ((atom exp) (setf *cursor-code-depth* depth)))
648     tree))
649
650 (defun find-in-source (var code &optional global exp)
651   (let (found)
652     (labels ((class-only (name)
653                (x:if-it (position #\( name)
654                    (subseq name 0 x:it)
655                    name))
656              (walk-tree (tree var depth)
657                (when tree
658                  (dolist (el tree)
659                    (unless (atom el)
660                      (if global
661                          (when (and (find (first el) '(defconstant defparameter defvar))
662                                     (eql var (second el)))
663                            (case (first (third el))
664                              (qnew
665                                 (return-from find-in-source
666                                   (class-only (second (third el)))))
667                              (qload-ui
668                                 (return-from find-in-source
669                                   (if exp el (qui-class (eval (second (third el)))))))
670                              (qfind-child
671                                 (return-from find-in-source
672                                   (qui-class (eval (second (third (find-in-source (second (third el)) code :global :exp))))
673                                              (third (third el)))))))
674                          (when (< depth *cursor-code-depth*)
675                            (case (first el)
676                              ((let let*)
677                                 (dolist (curr (second el))
678                                   (when (eql var (first curr))
679                                     (case (first (second curr))
680                                       (qnew
681                                          (setf found (second (second curr))))
682                                       (qfind-child
683                                          (setf found (qui-class (eval (second (find-in-source (second (second curr)) code nil :exp)))
684                                                                 (third (second curr)))))))))
685                              (qlet
686                                  (dolist (curr (second el))
687                                    (when (eql var (first curr))
688                                      (let ((name (second curr)))
689                                        (setf found (subseq name 0 (position #\( name))))))))))
690                      (walk-tree el var (1+ depth)))))))
691       (walk-tree code var 1)
692       (class-only found))))
693
694 (defun var-in-qlet-tree-p (code)
695   (labels ((walk-tree (tree depth)
696              (when tree
697                (dolist (el tree)
698                  (unless (atom el)
699                    (when (and (eql 'qlet (first el))
700                               (= 2 (- *cursor-code-depth* depth)))
701                      (return-from var-in-qlet-tree-p t))
702                    (walk-tree el (1+ depth)))))))
703     (walk-tree code 1)))
704
705 ;;; auto indent
706
707 (defun auto-indent-spaces (kw)
708   (when (symbolp kw)
709     (let ((name (symbol-name kw)))
710       (x:when-it (position +package-char-dummy+ name :from-end t)
711         (setf name (subseq name (1+ x:it))))
712       (cdr (find name *auto-indent* :test 'string= :key 'car)))))
713
714 (defun indentation (line)
715   (let ((pos (position #\Space line :test 'char/=)))
716     (if (char= #\; (char line pos))
717         pos
718         (let ((spaces (+ *current-depth* *current-keyword-indent*))) ; see right paren matcher
719           (when (and (zerop spaces)
720                      (not *extra-selections*)
721                      pos)
722             (setf spaces (if (char= #\( (char line pos))
723                              (if (find (read* (subseq line (1+ pos)))
724                                        '(loop prog progn prog1 prog2 unless when when-it when-it* while))
725                                  (+ pos 2)
726                                  (1+ (or (position #\Space line :start pos)
727                                          pos)))
728                              pos)))
729           spaces))))
730
731 (defun no-string-parens (line)
732   (let ((ex #\Space)
733         in-string)
734     (dotimes (i (length line))
735       (let ((ch (char line i)))
736         (case ch
737           (#\"
738              (unless (char= #\\ ex)
739                (setf in-string (not in-string))))
740           ((#\( #\))
741              (when in-string
742                (setf (char line i) #\Space))))
743         (setf ex ch))))
744   line)
745
746 (defun editor-key-pressed (key-event)
747   (case (qfun key-event "key")
748     ((#.|Qt.Key_Return| #.|Qt.Key_Enter|)
749      (let* ((cursor (qfun *editor* "textCursor"))
750             (curr (qfun cursor "block"))
751             (spaces (indentation (qfun curr "text"))))
752        (unless (zerop spaces)
753          (qfun cursor "insertText" (format nil "~%~A" (make-string spaces :initial-element #\Space)))
754          (qfun *editor* "ensureCursorVisible")
755          t)))
756     (#.|Qt.Key_Tab|
757        ;; auto indent paragraph: current line -> next empty line
758        (let ((cursor* (qfun *editor* "textCursor")))
759          (qfun cursor* "movePosition" |QTextCursor.StartOfLine| |QTextCursor.MoveAnchor|)
760          (qfun *editor* "setTextCursor" cursor*)
761          (let ((orig* (qfun *editor* "textCursor")))
762            (loop
763               (let ((spaces 0))
764                 (let ((cursor (qfun *editor* "textCursor"))  ; returns a copy
765                       (orig   (qfun *editor* "textCursor"))) ; (see above)
766                   (unless (zerop (qfun cursor "blockNumber"))
767                     (qfun cursor "movePosition" |QTextCursor.PreviousBlock| |QTextCursor.MoveAnchor|)
768                     (qfun *editor* "setTextCursor" cursor)
769                     (let ((curr (qfun cursor "block")))
770                       (let ((line (no-string-parens (qfun curr "text"))))
771                         (unless (or (x:empty-string line)
772                                     (char= #\; (find #\Space line :test 'char/=)))
773                           ;; apply right paren matcher (for indent info)
774                           (do* ((i (1- (length line)) (1- i))
775                                 (ch (char line i) (char line i)))
776                                ((zerop i))
777                             (when (char= #\) ch)
778                               (show-matching-parenthesis cursor (subseq line 0 (1+ i)) :right)
779                               (when *extra-selections*
780                                 (return)))))
781                         (setf spaces (indentation line)))))
782                   (qfun *editor* "setTextCursor" orig)
783                   ;; select current indent spaces (to be substituted)
784                   (let* ((curr (qfun orig "block"))
785                          (line (qfun curr "text"))
786                          (pos (position #\Space line :test 'char/=)))
787                     (when (zerop (length (string-trim " " line)))
788                       (return))                                                                      ; exit 1
789                     (when (not (zerop pos))
790                       (x:do-with (qfun orig "movePosition")
791                         (|QTextCursor.StartOfLine| |QTextCursor.MoveAnchor|)
792                         (|QTextCursor.NextCharacter| |QTextCursor.KeepAnchor| pos))))
793                   (unless (zerop spaces)
794                     (qfun orig "insertText" (make-string spaces :initial-element #\Space)))))
795               (unless (qfun cursor* "movePosition" |QTextCursor.NextBlock| |QTextCursor.MoveAnchor|)
796                 (return))                                                                            ; exit 2
797               (qfun *editor* "setTextCursor" cursor*))
798            (x:do-with (qfun *editor*)
799              ("setTextCursor" orig*)
800              "ensureCursorVisible")))
801        t)))
802
803 ;;; paren highlighting
804
805 (defun left-paren (text-cursor curr-line pos)
806   (let ((curr-n (qfun text-cursor "blockNumber"))
807         (start 0)
808         lines)
809     (flet ((try-read (curr-line*)
810              (setf lines (nconc lines (list curr-line*)))
811              (let ((code (with-output-to-string (s)
812                            (dolist (line lines)
813                              (write-line line s)))))
814                ;; proceed only without EOF Lisp reader error (for performance reasons)
815                (read* code)
816                (unless (eql :end-of-file *try-read-error*)
817                  (do ((end (position #\) code :start start) (position #\) code :start (1+ end))))
818                      ((null end))
819                    (let ((code* (subseq code 0 (1+ end))))
820                      (multiple-value-bind (exp end*)
821                          (if (string= "()" code*)
822                              (values '(nil) 2)
823                              (read* code*))
824                        (when (consp exp)
825                          (let ((n-lines (1- (length lines))))
826                            (return-from left-paren (values n-lines                           ; lines down
827                                                            (1- (if (zerop n-lines)           ; characters right
828                                                                    (+ pos end*)
829                                                                    (- end* start))))))))))))
830              (incf start (1+ (length curr-line*)))))
831       (try-read curr-line)
832       (let ((max (qfun (document) "blockCount")))
833         (when (< curr-n max)
834           (do ((n (1+ curr-n) (1+ n))
835                (text-block (qfun (qfun text-cursor "block") "next") (qfun text-block "next")))
836               ((>= n max))
837             (try-read (qfun text-block "text"))))))))
838
839 (defun right-paren (text-cursor curr-line)
840   (let ((curr-n (qfun text-cursor "blockNumber"))
841         lines)
842     (flet ((try-read (curr-line* &optional first)
843              (push curr-line* lines)
844              (let ((code (with-output-to-string (s)
845                            (dolist (line lines)
846                              (write-line line s)))))
847                ;; proceed only on provoked EOF Lisp reader error (for performance reasons)
848                (read* (concatenate 'string "(" code))
849                (when (eql :end-of-file *try-read-error*) 
850                  (do ((start (position #\( code :end (length curr-line*) :from-end t) (position #\( code :end start :from-end t)))
851                      ((null start))
852                    (unless (and (plusp start)
853                                 (char= #\\ (char code (1- start))))
854                      (let ((code* (subseq code (if (and (plusp start)
855                                                         (char= #\` (char code (1- start)))) ; macros etc.
856                                                    (1- start)
857                                                    start))))
858                        (multiple-value-bind (exp end)
859                            (if (x:starts-with "()" code*)
860                                (values '(nil) 2)
861                                (read* code*))
862                          (cond ((and (consp exp)
863                                      end
864                                      (= end (1- (length code*))))
865                                 (setf *current-depth* start)
866                                 (x:when-it (position #\( code :end start :from-end t)
867                                   (let* ((kw (read* (subseq code (1+ x:it))))
868                                          (spc (auto-indent-spaces kw)))
869                                     (when spc
870                                       (setf *current-depth* x:it
871                                             *current-keyword-indent* spc))))
872                                 (return-from right-paren (values (1- (length lines)) ; lines up
873                                                                  start)))            ; characters right
874                                ((null exp)
875                                 (let* ((kw (read* (subseq code 1)))
876                                        (spc (auto-indent-spaces kw)))
877                                   (when spc
878                                     (setf *current-depth* 0
879                                           *current-keyword-indent* spc)
880                                     (return-from right-paren)))))))))))
881              (when (x:starts-with "(" curr-line*)
882                (return-from right-paren))))
883       (try-read curr-line t)
884       (when (plusp curr-n)
885         (do ((n (1- curr-n) (1- n))
886              (text-block (qfun (qfun text-cursor "block") "previous") (qfun text-block "previous")))
887             ((minusp n))
888           (try-read (qfun text-block "text")))))))
889
890 (let ((color (qnew "QBrush(QColor)" "#FFFF40"))
891       (color-region (qnew "QBrush(QColor)" "#FFD0D0"))
892       pos-open pos-close)
893   (defun show-matching-parenthesis (text-cursor line type &optional pos)
894     (multiple-value-bind (move-lines move-characters)
895         (if (eql :left type)
896             (left-paren text-cursor line pos)
897             (right-paren text-cursor line))
898       (when move-lines
899         (qlet ((format "QTextCharFormat"))
900           (let ((cursor1 (qfun *current-editor* "textCursor"))
901                 (cursor2 (qfun *current-editor* "textCursor")))
902             (qfun format "setBackground" (if *error-region* color-region color))
903             (qfun cursor1 "movePosition" (if (eql :left type)
904                                              |QTextCursor.NextCharacter|
905                                              |QTextCursor.PreviousCharacter|)
906                   |QTextCursor.KeepAnchor|)
907             (if (zerop move-lines)
908                 (qfun cursor2 "movePosition"
909                       |QTextCursor.StartOfLine|
910                       (if *error-region* |QTextCursor.KeepAnchor| |QTextCursor.MoveAnchor|))
911                 (qfun cursor2 "movePosition"
912                       (if (eql :left type) |QTextCursor.NextBlock| |QTextCursor.PreviousBlock|)
913                       (if *error-region* |QTextCursor.KeepAnchor| |QTextCursor.MoveAnchor|)
914                       move-lines))
915             (unless (zerop move-characters)
916               (qfun cursor2 "movePosition"
917                     |QTextCursor.NextCharacter|
918                     (if *error-region* |QTextCursor.KeepAnchor| |QTextCursor.MoveAnchor|)
919                     move-characters))
920             (unless *error-region*
921               (qfun cursor2 "movePosition" |QTextCursor.NextCharacter| |QTextCursor.KeepAnchor|))
922             (qfun *current-editor* "setExtraSelections" (list (list cursor1 format)
923                                                               (list cursor2 format)))
924             (let ((p1 (qfun cursor1 "position"))
925                   (p2 (qfun cursor2 "position")))
926               (setf pos-open (1- (min p1 p2))
927                     pos-close (max p1 p2))
928               (when (= p1 pos-close)
929                 (incf pos-close)))
930             (setf *extra-selections* t))))))
931   (defun highlighted-parenthesis-text ()
932     (setf *latest-eval-position* pos-open)
933     (subseq (qget *current-editor* "plainText") pos-open pos-close)))
934
935 (defun mark-error-region (file-pos)
936   (when (string= *file-name* (file-namestring (car file-pos)))
937     (let* ((text (qget *editor* "plainText"))
938            (end (nth-value 1 (read* text (cdr file-pos))))
939            (*keep-extra-selections* t)
940            (text-cursor (qfun *editor* "textCursor")))
941       (qfun *editor* "moveCursor" |QTextCursor.Start|)
942       (setf *error-region* t)
943       (qfun text-cursor "setPosition" end)
944       (x:do-with (qfun *editor*)
945         ("setTextCursor" text-cursor)
946         "ensureCursorVisible"))))
947
948 ;;; external lisp process
949
950 (defun run-on-server (str)
951   (qprocess-events)
952   (or (local-client:request str)
953       (when (= |QMessageBox.Yes|
954                (qlet ((msg "QMessageBox"))
955                  (x:do-with (qfun msg)
956                    ("setText" (tr "<p>The <code><b style='color: blue'>local-server</b></code> seems not running.</p><p>Start it now?</p>"))
957                    ("setStandardButtons" (logior |QMessageBox.Yes| |QMessageBox.No|))
958                    ("setDefaultButton(QMessageBox::StandardButton)" |QMessageBox.No|)
959                    "exec")))
960         (qfun "QProcess" "startDetached" "eql local-server")
961         ;; wait max. 10 seconds
962         (dotimes (i 100)
963           (qprocess-events)
964           (when (local-client:request str)
965             (return-from run-on-server t))
966           (sleep 0.1))
967         nil)))
968
969 (defun save-and-run ()
970   (file-save)
971   (run-on-server (format nil "(load ~S)" *file-name*)))
972
973 (defun eval-region ()
974   (run-on-server (highlighted-parenthesis-text)))
975
976 (defun repeat-eval ()
977   (when *latest-eval-position*
978     (let ((text (qget *current-editor* "plainText")))
979       (when (< *latest-eval-position* (length text))
980         (let ((text* (subseq text *latest-eval-position*)))
981           (x:when-it (end-position text*)
982             (run-on-server (subseq text* 0 x:it))
983             (return-from repeat-eval))))))
984   (qmsg (tr "No valid latest region found.")))
985
986 (defun data-from-server (type str)
987   (case type
988     ((:expression :output :values :trace :error)
989        (when (find type '(:trace :error))
990          ;; fresh line
991          (let ((nl (string #\Newline)))
992            (unless (x:starts-with nl str)
993              (let ((cur (qfun *output* "textCursor")))
994                (unless (zerop (qfun cur "columnNumber"))
995                  (qfun *output* "insertPlainText" nl))))))
996        (x:do-with (qfun *output*)
997          ("moveCursor" |QTextCursor.End|)
998          ("setTextColor" (case type
999                            (:output "sienna")
1000                            (:values "blue")
1001                            (:trace  "darkmagenta")
1002                            (:error  "red")
1003                            (t       "black")))
1004          ("insertPlainText" str))
1005        (let ((vs (qfun *output* "verticalScrollBar")))
1006          (qset vs "value" (qget vs "maximum"))))
1007     (:file-position
1008        (mark-error-region (read-from-string str)))
1009     (:activate-editor
1010        (x:do-with (qfun *main*)
1011          "activateWindow"
1012          "raise"))))
1013
1014 ;;; command line
1015
1016 (defun command ()
1017   (let ((text (string-trim '(#\Newline) (qget *command* "plainText"))))
1018     (when (run-on-server text)
1019       (history-add text))
1020     (qfun *command* "clear")))
1021
1022 (defun saved-history ()
1023   (let ((ex "")
1024         history)
1025     (when (probe-file +history-file+)
1026       (with-open-file (s +history-file+ :direction :input)
1027         (loop
1028            (let ((cmd (read-line s nil :eof)))
1029              (when (eql :eof cmd)
1030                (return))
1031              (unless (string= ex cmd)
1032                (push (setf ex cmd) history)))))
1033       (setf history (nthcdr (max 0 (- (length history) +max-history+)) (reverse history)))
1034       (ignore-errors (delete-file +history-file+))
1035       (with-open-file (s +history-file+ :direction :output
1036                          :if-does-not-exist :create)
1037         (dolist (cmd history)
1038           (write-line cmd s)))
1039       (reverse history))))
1040
1041 (let ((up (saved-history))
1042       (out (open +history-file+ :direction :output
1043                  :if-exists :append :if-does-not-exist :create))
1044       down)
1045   (defun command-key-pressed (ev)
1046     (x:when-it (case (qfun ev "key")
1047                  (#.|Qt.Key_Up|
1048                     (x:when-it (pop up)
1049                       (push x:it down)))
1050                  (#.|Qt.Key_Down|
1051                     (x:when-it (pop down)
1052                       (push x:it up)))
1053                  ((#.|Qt.Key_Return| #.|Qt.Key_Enter|)
1054                     (command)
1055                     nil))
1056       (qset *command* "plainText" (first x:it)))
1057     nil) ; overridden
1058   (defun history-add (cmd)
1059     (when (or (not up)
1060               (and up (string/= cmd (first up))))
1061       (push cmd up)
1062       (princ cmd out)
1063       (terpri out)
1064       (when (and down (string= cmd (first down)))
1065         (pop down))))
1066   (defun history ()
1067     (append (reverse up) down)))
1068
1069 ;;; find, replace
1070
1071 (defun find-text ()
1072   (unless (qfun *editor* "find" (qget *find* "text"))
1073     (qfun *editor* "moveCursor" |QTextCursor.Start|)))
1074
1075 (defun replace-text ()
1076   (qfun (qfun *editor* "textCursor") "insertText" (qget *replace* "text"))
1077   (find-text))
1078
1079 ;;; profile
1080
1081 #|
1082 (require :profile)
1083
1084 (progn
1085   (use-package :profile)
1086   (profile:profile
1087    highlight-block
1088    left-paren
1089    right-paren
1090    read*))
1091 |#
1092
1093 ;;; ini
1094
1095 (defun start ()
1096   (ini)
1097   (file-open (x:if-it (third (qfun "QCoreApplication" "arguments"))
1098                  x:it
1099                  "my.lisp")))
1100
1101 (start)