mirror of
https://gitlab.com/eql/EQL5.git
synced 2025-12-06 02:30:31 -08:00
446 lines
16 KiB
Common Lisp
446 lines
16 KiB
Common Lisp
;;; copyright (c) Polos Ruetz
|
|
|
|
;; load all available modules for documentation purposes
|
|
(dolist (module (list :help :multimedia :network :quick :sql :svg :webengine :webkit))
|
|
(eql:qrequire module :quiet))
|
|
|
|
(defpackage :gui
|
|
(:use :common-lisp :eql)
|
|
(:export
|
|
#:*q*
|
|
#:*gui*
|
|
#:*display*
|
|
#:*edit*))
|
|
|
|
(provide :gui)
|
|
|
|
(in-package :gui)
|
|
|
|
(defparameter * nil)
|
|
(defparameter ** nil)
|
|
(defparameter *** nil)
|
|
(defparameter *q* nil)
|
|
|
|
(defvar *gui* (qload-ui (in-home "lib/gui.ui")))
|
|
|
|
(defvar-ui *gui*
|
|
*display*
|
|
*edit*
|
|
*help*
|
|
*hint-copy-1*
|
|
*hint-copy-2*
|
|
*main-tab*
|
|
*n-methods*
|
|
*n-names*
|
|
*n-override*
|
|
*n-super-classes*
|
|
*package-name*
|
|
*properties*
|
|
*primitives*
|
|
*q-methods*
|
|
*q-names*
|
|
*q-override*
|
|
*q-properties*
|
|
*q-signals*
|
|
*q-slots*
|
|
*q-super-classes*
|
|
*qt-tab*
|
|
*search-class*
|
|
*search-help*
|
|
*select*
|
|
*selected-widget*
|
|
*tabs-non-qobjects*
|
|
*tabs-qobjects*)
|
|
|
|
(defvar *code-font* (qnew "QFont(QString,int)"
|
|
#+darwin "Monaco" #+darwin 12
|
|
#+linux "Monospace" #+linux 9
|
|
#+windows "Courier New" #+windows 10))
|
|
|
|
(defvar *completer-list* (qnew "QStringListModel"))
|
|
|
|
(defun gui ()
|
|
(qset *gui* "windowTitle" "EQL - Embedded Qt Lisp")
|
|
(qset *select* "toolTip" (tr "Select any (child) widget (see qsel:*q*)"))
|
|
(qset *help* "source" (! "fromLocalFile" "QUrl" (in-home "doc/auto-doc.htm")))
|
|
(qset *hint-copy-2* "text" (qget *hint-copy-1* "text"))
|
|
(qset-color *help* |QPalette.Highlight| "yellow")
|
|
(qset-color *help* |QPalette.HighlightedText| "black")
|
|
(set-tree *q-override*)
|
|
(set-tree *q-signals*)
|
|
(set-tree *q-slots*)
|
|
(set-tree *q-methods* 3 nil nil (tr "Static"))
|
|
(set-tree *q-properties* 3 nil nil (tr "Read Only"))
|
|
(set-tree *n-methods* 3 nil (tr "Method") (tr "Static"))
|
|
(set-tree *n-override*)
|
|
(set-tree *primitives* 2 (tr "Qt/C++ type") (tr "Lisp example / type"))
|
|
(populate-primitives)
|
|
;; please see example 9, "editor.lisp" for better completer examples
|
|
(let ((cpl (qnew "QCompleter")))
|
|
(dolist (w (list *display* *edit* *package-name* *selected-widget* *search-class* (! "popup" cpl)))
|
|
(qset w "font" *code-font*))
|
|
(! "setModel" cpl *completer-list*)
|
|
(! "setCompleter" *edit* cpl))
|
|
(let ((cpl (qnew "QCompleter(QStringList)" (append (qobject-names) (primitives)))))
|
|
(! "setCompletionMode" cpl |QCompleter.InlineCompletion|)
|
|
(! "setCaseSensitivity" cpl |Qt.CaseInsensitive|)
|
|
(! "setCompleter" *search-class* cpl))
|
|
(! "addItems" *q-names* (qobject-names :q))
|
|
(! "addItems" *n-names* (qobject-names :n))
|
|
(qconnect *q-super-classes* "linkActivated(QString)" 'change-class-q-object)
|
|
(qconnect *n-super-classes* "linkActivated(QString)" 'change-class-n-object)
|
|
(qconnect *q-names* "activated(QString)" 'change-q-object)
|
|
(qconnect *n-names* "activated(QString)" 'change-n-object)
|
|
(qconnect *edit* "returnPressed()" 'eval-edit)
|
|
(qconnect *select* "clicked()" (lambda () (qselect 'widget-selected)))
|
|
(qconnect *properties* "clicked()" 'show-properties-dialog)
|
|
(qconnect *search-class* "returnPressed()" 'select-class)
|
|
(qconnect *search-help* "textChanged(QString)" 'search-help)
|
|
(qconnect *search-help* "returnPressed()" 'search-help)
|
|
(qoverride *edit* "keyPressEvent(QKeyEvent*)" 'key-pressed)
|
|
(change-class-q-object "QWidget" :super)
|
|
(change-class-n-object "QMetaObject" :super)
|
|
(qsingle-shot 500 'show-package-name)
|
|
(x:do-with (qset *gui*)
|
|
("pos" (list 50 50))
|
|
("size" (list 700 500)))
|
|
(! "setFocus" *edit*)
|
|
(x:do-with *gui* "show" "raise"))
|
|
|
|
(defun search-help (&optional text)
|
|
(flet ((move-start ()
|
|
(! "moveCursor" *help* |QTextCursor.Start|)))
|
|
(when text
|
|
(move-start))
|
|
(unless (! "find" *help* (! "text" *search-help*))
|
|
(move-start))))
|
|
|
|
(defun key-pressed (event)
|
|
(case (! "key" event)
|
|
(#.|Qt.Key_Up|
|
|
(history-move :back))
|
|
(#.|Qt.Key_Down|
|
|
(history-move :forward)))
|
|
(qcall-default))
|
|
|
|
(defun set-tree (tree &optional (cols 2) lb1 lb2 lb3)
|
|
(x:do-with (qset tree)
|
|
("alternatingRowColors" t)
|
|
("sortingEnabled" t)
|
|
("rootIsDecorated" nil))
|
|
(let ((lbs (list (or lb1 (tr "Type"))
|
|
(or lb2 (tr "Name"))
|
|
lb3)))
|
|
(x:do-with tree
|
|
("setHeaderLabels" (butlast lbs (- 3 cols)))
|
|
("sortByColumn" (if (> cols 1) 1 0) |Qt.AscendingOrder|))
|
|
(qconnect tree "itemDoubleClicked(QTreeWidgetItem*,int)" 'add-to-edit)))
|
|
|
|
(let ((cross-cursor (qnew "QCursor(Qt::CursorShape)" |Qt.CrossCursor|)))
|
|
(defun select-mode ()
|
|
(set-listen t)
|
|
(! "setOverrideCursor" "QGuiApplication" cross-cursor)))
|
|
|
|
(defun select-class ()
|
|
(let ((name (! "text" *search-class*))
|
|
found)
|
|
(flet ((find-name (q-n)
|
|
(unless found
|
|
(setf found (find name (if q-n (qobject-names q-n) (primitives))
|
|
:test 'string-equal))))
|
|
(set-tab-index (i)
|
|
(! "setCurrentIndex" *qt-tab* i)))
|
|
(cond ((find-name :q) ; QObject
|
|
(set-tab-index 0)
|
|
(change-class-q-object found :super))
|
|
((find-name :n) ; non QObject
|
|
(set-tab-index 1)
|
|
(change-class-n-object found :super))
|
|
((find-name nil) ; primitive
|
|
(set-tab-index 2)
|
|
(dotimes (i (! "topLevelItemCount" *primitives*))
|
|
(let ((item (! "topLevelItem" *primitives* i)))
|
|
(when (search found (! "text" item 0))
|
|
(! "setCurrentItem" *primitives* item)
|
|
(! "setFocus" *primitives*)
|
|
(return)))))
|
|
(t
|
|
(! "selectAll" *search-class*))))))
|
|
|
|
(defun change-class-q-object (s &optional super)
|
|
(let ((i (! "findText" *q-names* s)))
|
|
(if (= -1 i)
|
|
(qmsg (tr "Sorry, class not found."))
|
|
(progn
|
|
(! "setCurrentIndex" *q-names* i)
|
|
(change-q-object nil super)))))
|
|
|
|
(defun change-class-n-object (s &optional super)
|
|
(! "setCurrentIndex" *n-names* (! "findText" *n-names* s))
|
|
(change-n-object nil super))
|
|
|
|
(defun change-q-object (&optional s (super t))
|
|
(populate-objects :q)
|
|
(when super
|
|
(show-super-classes :q)))
|
|
|
|
(defun change-n-object (&optional s (super t))
|
|
(populate-objects :n)
|
|
(when super
|
|
(show-super-classes :n)))
|
|
|
|
(defun populate-objects (type)
|
|
(let* ((class (qget (if (eql :q type) *q-names* *n-names*) "currentText"))
|
|
(info (qapropos* nil class type))
|
|
(all (rest (first info)))
|
|
(tabs (if (eql :q type) *tabs-qobjects* *tabs-non-qobjects*))
|
|
(i-tab -1))
|
|
(flet ((sub (name)
|
|
(rest (find name all :key 'first :test 'string=))))
|
|
(mapc (lambda (name tree)
|
|
(incf i-tab)
|
|
(! "clear" tree)
|
|
(dolist (curr (sub name))
|
|
(let* ((curr* (x:string-substitute "const_" "const " curr))
|
|
(item (qnew "QTreeWidgetItem"))
|
|
(sp1 (position #\Space curr*))
|
|
(sp2 (when sp1 (position #\Space curr* :start (1+ sp1)))))
|
|
(! "setTextAlignment" item 0 (logior |Qt.AlignRight| |Qt.AlignVCenter|))
|
|
(when sp1
|
|
(! "setText" item 0 (subseq curr 0 sp1)))
|
|
(! "setText" item 1 (x:cc (if (string= "constructor" (! "text" item 0)) ": " "")
|
|
(if sp1 (subseq curr (1+ sp1) sp2) curr)))
|
|
(when sp2
|
|
(! "setText" item 2 (subseq curr (1+ sp2))))
|
|
(! "addTopLevelItem" tree item)))
|
|
(resize-tree tree)
|
|
(! "sortByColumn" tree 1 |Qt.AscendingOrder|)
|
|
(! "setTabEnabled" tabs i-tab (not (zerop (! "topLevelItemCount" tree)))))
|
|
(if (eql :q type)
|
|
(list "Properties:" "Methods:" "Slots:" "Signals:")
|
|
(list "Methods:"))
|
|
(if (eql :q type)
|
|
(list *q-properties* *q-methods* *q-slots* *q-signals*)
|
|
(list *n-methods*)))
|
|
(incf i-tab)
|
|
(let ((override (if (eql :q type) *q-override* *n-override*)))
|
|
(! "clear" override)
|
|
(dolist (curr (sub "Override:"))
|
|
(let ((item (qnew "QTreeWidgetItem"))
|
|
(sp (position #\Space curr :start (if (x:starts-with "const" curr) 6 0))))
|
|
(x:do-with item
|
|
("setTextAlignment" 0 (logior |Qt.AlignRight| |Qt.AlignVCenter|))
|
|
("setText" 0 (subseq curr 0 sp))
|
|
("setText" 1 (subseq curr (1+ sp))))
|
|
(! "addTopLevelItem" override item)))
|
|
(! "sortByColumn" override 1 |Qt.AscendingOrder|)
|
|
(! "setTabEnabled" tabs i-tab (not (zerop (! "topLevelItemCount" override))))))
|
|
(when (null info)
|
|
(qmsg "<html>Class currently not available (see EQL modules and <b><code>qrequire</code></b>)."))))
|
|
|
|
(defun populate-primitives ()
|
|
(dolist (type (list (cons "QByteArray" "(vector -50 0 50) ; convenient for binary data exchange Lisp <-> C++")
|
|
(cons "QChar" "#\\a")
|
|
(cons "QColor" "(or \"#FF0000\" \"green\" (qnew \"QColor(QString)\" \"blue\"))")
|
|
(cons "QGradientStop" "(cons 0 color)")
|
|
(cons "QLine / QLineF" "(list x1 y1 x2 y2)")
|
|
(cons "QPoint / QPointF" "(list x y)")
|
|
(cons "QPolygon / QPolygonF" "(list x1 y1 x2 y2 x3 y3 ...)")
|
|
(cons "QRect / QRectF" "(list x y width height)")
|
|
(cons "QRgb" "(qrgb r g b &optional a)")
|
|
(cons "QSize / QSizeF" "(list width height)")
|
|
(cons "QString" "\"a Unicode string\"")
|
|
(cons "QStringList" "(list \"one\" \"two\" \"three\")")
|
|
(cons "GLint" "<integer>")
|
|
(cons "GLuint" "<unsigned integer>")
|
|
(cons "GLenum" "<unsigned integer>")
|
|
(cons "GLfloat" "<single float>")))
|
|
(let ((item (qnew "QTreeWidgetItem")))
|
|
(x:do-with item
|
|
("setText" 0 (car type))
|
|
("setText" 1 (cdr type)))
|
|
(! "addTopLevelItem" *primitives* item)))
|
|
(x:do-with *primitives*
|
|
("resizeColumnToContents" 0)
|
|
("sortByColumn" 0 |Qt.AscendingOrder|)))
|
|
|
|
(let (primitives)
|
|
(defun primitives ()
|
|
(or primitives
|
|
(setf primitives
|
|
(let (names)
|
|
(dotimes (i (! "topLevelItemCount" *primitives*))
|
|
(let ((name (! "text" (! "topLevelItem" *primitives* i) 0)))
|
|
(if (find #\/ name)
|
|
(dolist (el (x:split name #\/))
|
|
(push (string-trim " " el) names))
|
|
(push name names))))
|
|
names)))))
|
|
|
|
(defun show-super-classes (type)
|
|
(qset (if (eql :q type) *q-super-classes* *n-super-classes*) "text"
|
|
(with-output-to-string (s)
|
|
(do ((super (qget (if (eql :q type) *q-names* *n-names*) "currentText")
|
|
(qsuper-class-name super)))
|
|
((null super))
|
|
(format s "<a href='~A'>~A</a> " super super)))))
|
|
|
|
(defun resize-tree (tree)
|
|
(dotimes (i (! "columnCount" tree))
|
|
(! "resizeColumnToContents" tree i)))
|
|
|
|
(defun add-to-edit (item col)
|
|
(let ((txt (prin1-to-string (! "text" item
|
|
(min 1 (1- (! ("columnCount" "treeWidget" item))))))))
|
|
(! (("setText" txt) "clipboard" "QApplication"))
|
|
(let ((curr (qget *edit* "text")))
|
|
(when (and (x:starts-with "(" curr)
|
|
(not (x:ends-with "\"" curr)))
|
|
(! "setText" *edit* (x:cc (qget *edit* "text") txt)))))
|
|
(! "setFocus" *edit*))
|
|
|
|
(defun display (x &optional color)
|
|
(when color
|
|
(! "insertHtml" *display* (format nil "<font color=~A> " color)))
|
|
(let ((1st t))
|
|
(dolist (val (x:ensure-list x))
|
|
(! "insertPlainText" *display*
|
|
(format nil "~A~A~%" (if 1st (progn (setf 1st nil) "") " ") val))))
|
|
(when color
|
|
(! "insertHtml" *display* "<br></font>"))
|
|
(let ((vs (! "verticalScrollBar" *display*)))
|
|
(qset vs "value" (qget vs "maximum")))
|
|
(show-package-name))
|
|
|
|
(defun show-error (err color)
|
|
(let ((e1 (prin1-to-string err))
|
|
(e2 (princ-to-string err)))
|
|
(display e1 color)
|
|
(unless (string= e1 e2)
|
|
(display e2 color)))
|
|
nil)
|
|
|
|
(defun all-symbols ()
|
|
(let (all)
|
|
(do-symbols (s)
|
|
(let ((name (symbol-name s)))
|
|
(push (x:cc (if (or (ignore-errors (symbol-function s))
|
|
(macro-function s))
|
|
"("
|
|
"")
|
|
(if (some 'lower-case-p name)
|
|
(format nil "|~A|" name)
|
|
(string-downcase name)))
|
|
all)))
|
|
(sort all 'string<)))
|
|
|
|
(let (package)
|
|
(defun show-package-name ()
|
|
(unless package
|
|
(in-package :eql-user))
|
|
(let ((name (package-name *package*)))
|
|
(qset *package-name* "text" (format nil "~A>" name))
|
|
(when (string/= name package)
|
|
(let ((*standard-output* nil)) ; suppress output to console (slow on Windows)
|
|
(! "setStringList" *completer-list* (all-symbols)))
|
|
(setf package name)))))
|
|
|
|
(defun eval-edit ()
|
|
(let ((color "darkorange"))
|
|
(handler-case
|
|
(let ((txt (string-trim " " (qget *edit* "text"))))
|
|
(unless (x:empty-string txt)
|
|
(display (format nil "~A> ~A" (package-name *package*) txt))
|
|
(let ((exp (read-from-string txt)))
|
|
(setf color "red")
|
|
(let ((vals (multiple-value-list (eval exp))))
|
|
(setf *** ** ** * * (first vals))
|
|
(display (mapcar 'prin1-to-string vals) "blue")
|
|
(history-add txt)
|
|
(! "clear" *edit*)))))
|
|
(condition (c)
|
|
(show-error c color)))))
|
|
|
|
(defun focus-me ()
|
|
(x:do-with *gui* "activateWindow" "raise")
|
|
(! "setFocus" *edit*))
|
|
|
|
(defun widget-selected (widget)
|
|
(setf *q* widget)
|
|
(! "setText" *selected-widget* (prin1-to-string *q*))
|
|
(! "setEnabled" *properties* t)
|
|
(change-class-q-object (qt-object-name *q*) :super)
|
|
(focus-me))
|
|
|
|
(defun show-properties-dialog ()
|
|
(unless (find-package :properties)
|
|
(load (in-home "lib/properties")))
|
|
(funcall (find-symbol "SHOW" :properties) *q*))
|
|
|
|
;;; command history
|
|
|
|
(defvar *history* (make-array 0 :adjustable t :fill-pointer t))
|
|
(defvar *history-index* nil)
|
|
(defvar *history-file* ".command-history")
|
|
(defvar *max-history* 100)
|
|
|
|
(defun read-saved-history ()
|
|
(when (probe-file *history-file*)
|
|
(let ((i -1))
|
|
(labels ((index ()
|
|
(mod i *max-history*))
|
|
(next-index ()
|
|
(incf i)
|
|
(index)))
|
|
(let ((tmp (make-array *max-history*))) ; ring buffer
|
|
(with-open-file (s *history-file* :direction :input)
|
|
(x:while-it (read-line s nil nil)
|
|
(setf (svref tmp (next-index)) x:it)))
|
|
(let ((max (min (1+ i) *max-history*)))
|
|
(when (< max *max-history*)
|
|
(setf i -1))
|
|
(dotimes (n max)
|
|
(vector-push-extend (svref tmp (next-index))
|
|
*history*))
|
|
(setf *history-index* (length *history*)))))))) ; 1 after last
|
|
|
|
(let (out)
|
|
(defun history-ini ()
|
|
(read-saved-history)
|
|
(setf out (open *history-file* :direction :output
|
|
:if-exists :append :if-does-not-exist :create)))
|
|
(defun history-add (line)
|
|
(unless out
|
|
(history-ini))
|
|
(let ((len (length *history*)))
|
|
(when (or (zerop len)
|
|
(string/= line (aref *history* (1- len))))
|
|
(vector-push-extend line *history*)
|
|
(write-line line out)
|
|
(finish-output out)))
|
|
(setf *history-index* (length *history*))) ; 1 after last
|
|
(defun history-move (dir)
|
|
(unless out
|
|
(history-ini))
|
|
(when *history-index*
|
|
(setf *history-index* (if (eql :back dir)
|
|
(max (1- *history-index*) 0)
|
|
(min (1+ *history-index*) (1- (length *history*)))))
|
|
(qset *edit* "text" (aref *history* *history-index*)))))
|
|
|
|
;;; start
|
|
|
|
(gui)
|
|
|
|
;;; profile
|
|
|
|
#|
|
|
(require :profile)
|
|
|
|
(progn
|
|
(use-package :profile)
|
|
(profile:profile
|
|
qfun
|
|
qset
|
|
qget))
|
|
|#
|