mirror of
https://gitlab.com/eql/EQL5.git
synced 2025-12-25 19:31:57 -08:00
126 lines
4.3 KiB
Common Lisp
126 lines
4.3 KiB
Common Lisp
;;; show output of QPROPERTIES in a QDialog
|
|
|
|
(defpackage :properties
|
|
(:nicknames prop)
|
|
(:use :common-lisp :eql)
|
|
(:export
|
|
#:*object*
|
|
#:*qml-stack*
|
|
#:show))
|
|
|
|
(in-package :properties)
|
|
|
|
(defvar *main* (qload-ui (in-home "gui/properties")))
|
|
|
|
(defvar-ui *main*
|
|
*meta-class-name*
|
|
*meta-class-names*
|
|
*property-view*
|
|
*class-depth*
|
|
*class-names*
|
|
*instance-properties*
|
|
*select*)
|
|
|
|
(defvar *font* (format nil "font-family: ~A; font-size: ~Apt;"
|
|
#+darwin "Monaco" #+darwin 12
|
|
#+linux "Monospace" #+linux 9
|
|
#+windows "Courier New" #+windows 10))
|
|
|
|
(defvar *object* nil)
|
|
(defvar *qml-stack* nil)
|
|
(defvar *ignore-update* nil)
|
|
|
|
(defun ini ()
|
|
(! "setSizeAdjustPolicy" *meta-class-name* |QComboBox.AdjustToContents|)
|
|
(! "setReadOnly" *property-view* t)
|
|
(! "setMinimum" *class-depth* 1)
|
|
(! "resize" *main* '(650 500))
|
|
(dolist (w (list *meta-class-names* *class-names*))
|
|
(! "setWordWrap" w t))
|
|
(qset-color *property-view* |QPalette.Base| "lightyellow")
|
|
(qconnect *meta-class-name* "currentIndexChanged(int)" 'update-meta-class-names)
|
|
(qconnect *class-depth* "valueChanged(int)" 'update)
|
|
(qconnect *instance-properties* "toggled(bool)" 'all-instance-properties)
|
|
(qconnect *select* "clicked()" 'selected))
|
|
|
|
(defun update (depth)
|
|
(! "setText" *class-names*
|
|
(with-output-to-string (s)
|
|
(let ((name (qt-object-name *object*)))
|
|
(princ name s)
|
|
(dotimes (i (1- depth))
|
|
(setf name (qsuper-class-name name))
|
|
(princ " - " s)
|
|
(princ name s)))))
|
|
(show))
|
|
|
|
(defun all-instance-properties (checked)
|
|
(dolist (w (list *class-depth* *class-names*))
|
|
(! "setEnabled" w (not checked)))
|
|
(show))
|
|
|
|
(defun selected ()
|
|
(qselect (lambda (object) (show (symbol-value (find-symbol (symbol-name :*q*) :qsel))))))
|
|
|
|
(defun super-class-names (object)
|
|
(flet ((name (name)
|
|
(subseq name 0 (position #\_ name))))
|
|
(let ((mo (! "metaObject" object))
|
|
names)
|
|
(x:while (not (qnull mo))
|
|
(pushnew (name (! "className" mo))
|
|
names :test 'string=)
|
|
(setf mo (! "superClass" mo)))
|
|
(nreverse names))))
|
|
|
|
(defun class-names (objects)
|
|
(flet ((name (name)
|
|
(subseq name 0 (position #\_ name))))
|
|
(let (names)
|
|
(dolist (object objects)
|
|
(pushnew (name (! "className" (! "metaObject" object)))
|
|
names :test 'string=))
|
|
(nreverse names))))
|
|
|
|
(defun update-meta-class-names (index)
|
|
(unless (or *ignore-update*
|
|
(= -1 index))
|
|
(let ((object (nth index *qml-stack*)))
|
|
(! "setText" *meta-class-names* (x:join (rest (super-class-names object)) " - "))
|
|
(show object t))))
|
|
|
|
(defun show (&optional object update)
|
|
(when object
|
|
(setf *object* object)
|
|
(when (find-package :qsel)
|
|
(setf *qml-stack* (symbol-value (find-symbol (symbol-name :*qml-stack*) :qsel))))
|
|
(let ((classes (super-class-names *object*))
|
|
(*ignore-update* t))
|
|
(if *qml-stack*
|
|
(unless update
|
|
(! "clear" *meta-class-name*)
|
|
(! "addItems" *meta-class-name* (class-names *qml-stack*)))
|
|
(progn
|
|
(! "clear" *meta-class-name*)
|
|
(! "addItem" *meta-class-name* (first classes))))
|
|
(! "setText" *meta-class-names* (x:join (rest classes) " - ")))
|
|
(! "setChecked" *instance-properties* (! "inherits" *object* "QQuickItem")) ; for QML items
|
|
(let ((depth 1)
|
|
(name (qt-object-name *object*)))
|
|
(! "setText" *class-names* name)
|
|
(! "setWindowTitle" *main* name)
|
|
(x:while (setf name (qsuper-class-name name))
|
|
(incf depth))
|
|
(! "setMaximum" *class-depth* depth)
|
|
(! "setValue" *class-depth* 1)))
|
|
(! "setHtml" *property-view* (format nil "<pre style='~A'>~A</pre>"
|
|
*font*
|
|
(qescape (with-output-to-string (*standard-output*)
|
|
(if (! "isChecked" *instance-properties*)
|
|
(qproperties* *object*)
|
|
(qproperties *object* (! "value" *class-depth*)))))))
|
|
(unless (! "isVisible" *main*)
|
|
(! "show" *main*)))
|
|
|
|
(ini)
|
|
|