mirrors/lqml
1
Fork 0
mirror of https://gitlab.com/eql/lqml.git synced 2025-12-06 02:30:38 -08:00
Code Issues Projects Releases Packages Wiki Activity

several small extensions, prepare for example 'cl-repl' to work

Browse source
This commit is contained in:
pls.153 2022-04-07 18:35:30 +02:00
parent b3eb6cb09a
commit 22fa212c88
12 changed files with 209 additions and 67 deletions
Download patch file Download diff file Expand all files Collapse all files

20
doc/help.htm
View file

@ -8,6 +8,11 @@
<h2><pre>LQML</pre></h2>
<pre>
<b>clipboard-text ()</b>
Calls QGuiApplication::clipboard()->text().
<b>define-qt-wrappers (qt-library &rest what)</b>
Defines Lisp methods for all Qt methods/signals/slots of given library,
@ -105,6 +110,11 @@
(qdirectory "assets:/lib")
<b>qeql (qt-object-1 qt-object-2)</b>
Returns T if passed QT-OBJECTs are pointer equal.
<b>qescape (string)</b>
Calls QString::toHtmlEscaped().
@ -202,9 +212,10 @@
Returns the QObject::objectName() of passed QT-OBJECT.
<b>qprocess-events ()</b>
<b>qprocess-events (&optional exclude-user-input)</b>
Calls QCoreApplication::processEvents().
Calls QCoreApplication::processEvents(). Pass T to exclude user input
events during event processing.
<b>qquit (&optional (exit-status 0) (kill-all-threads t))</b>
@ -251,6 +262,11 @@
Returns the root item of the QQuickView.
<b>set-clipboard-text (text)</b>
Calls QGuiApplication::clipboard()->setText().
<b>tr (source &optional context plural-number)</b>
Macro expanding to QTRANSLATE, which calls QCoreApplication::translate().

3
examples/sokoban/lisp/sokoban.lisp
View file

@ -115,7 +115,8 @@
(defun run-or-enqueue (function)
(if (zerop *running-animations*)
(funcall function)
(setf *function-queue* (nconc *function-queue* (list function)))))
(setf *function-queue*
(nconc *function-queue* (list function)))))
(defmacro queued (&rest functions)
"Run passed functions in order, waiting for currently running (or newly

2
platforms/shared/make.lisp
View file

@ -43,8 +43,6 @@
(load quicklisp-init))))
(load *ql-libs*)) ; eventual, not yet installed dependencies
;;; load ASDF system
(asdf:load-system *asdf-system*)
;;; *** (2) cross-compile ***

30
src/cpp/ecl_ext.cpp
View file

@ -9,6 +9,7 @@
#include <QThread>
#include <QFile>
#include <QDir>
#include <QClipboard>
#include <QQuickItem>
#include <QQuickView>
#include <QQmlEngine>
@ -27,6 +28,7 @@ void iniCLFunctions() {
cl_make_package(1, qml);
}
si_select_package(qml);
DEFUN ("clipboard-text", clipboard_text, 0)
DEFUN ("%ensure-permissions", ensure_permissions2, 1)
DEFUN ("%js", js2, 2)
DEFUN ("pixel-ratio", pixel_ratio, 0)
@ -47,7 +49,7 @@ void iniCLFunctions() {
DEFUN ("%qml-get", qml_get2, 2)
DEFUN ("%qml-set", qml_set2, 3)
DEFUN ("qobject-name", qobject_name, 1)
DEFUN ("qprocess-events", qprocess_events, 0)
DEFUN ("%qprocess-events", qprocess_events2, 1)
DEFUN ("%qquit", qquit2, 1)
DEFUN ("%qrun-on-ui-thread", qrun_on_ui_thread2, 2)
DEFUN ("%qget", qget2, 2)
@ -58,6 +60,7 @@ void iniCLFunctions() {
DEFUN ("qt-object-info", qt_object_info, 1)
DEFUN ("%reload", reload2, 0)
DEFUN ("root-item", root_item, 0)
DEFUN ("set-clipboard-text", set_clipboard_text, 1)
DEFUN ("%set-shutdown-p", set_shutdown_p, 1)
STATIC_SYMBOL_PKG (s_view_status_changed, "VIEW-STATUS-CHANGED", "QML")
@ -338,10 +341,15 @@ cl_object qescape(cl_object l_str) {
ecl_return1(ecl_process_env(), l_ret);
}
cl_object qprocess_events() {
/// args: ()
/// Calls QCoreApplication::processEvents().
cl_object qprocess_events2(cl_object l_exclude_user_input) {
/// args: (&optional exclude-user-input)
/// Calls QCoreApplication::processEvents(). Pass T to exclude user input
/// events during event processing.
if (l_exclude_user_input != ECL_NIL) {
QCoreApplication::processEvents(QEventLoop::ExcludeUserInputEvents);
} else {
QCoreApplication::processEvents();
}
ecl_return1(ecl_process_env(), ECL_T);
}
@ -594,6 +602,20 @@ cl_object reload2() {
ecl_return1(ecl_process_env(), l_ret);
}
cl_object clipboard_text() {
/// args: ()
/// Calls QGuiApplication::clipboard()->text().
cl_object l_text = from_qstring(QGuiApplication::clipboard()->text());
ecl_return1(ecl_process_env(), l_text);
}
cl_object set_clipboard_text(cl_object l_text) {
/// args: (text)
/// Calls QGuiApplication::clipboard()->setText().
QGuiApplication::clipboard()->setText(toQString(l_text));
ecl_return1(ecl_process_env(), l_text);
}
cl_object qcopy_file(cl_object l_from, cl_object l_to) {
/// args: (from to)
/// Convenience function for android, for e.g. copying files from 'assets:/',

4
src/cpp/ecl_ext.h
View file

@ -50,6 +50,7 @@ QT_BEGIN_NAMESPACE
#define LIST10(a1, a2, a3, a4, a5, a6, a7, a8, a9, a10) \
CONS(a1, LIST9(a2, a3, a4, a5, a6, a7, a8, a9, a10))
cl_object clipboard_text ();
cl_object ensure_permissions2 (cl_object);
cl_object js2 (cl_object, cl_object);
cl_object pixel_ratio ();
@ -70,7 +71,7 @@ cl_object qnull (cl_object);
cl_object qml_get2 (cl_object, cl_object);
cl_object qml_set2 (cl_object, cl_object, cl_object);
cl_object qobject_name (cl_object);
cl_object qprocess_events ();
cl_object qprocess_events2 (cl_object);
cl_object qquit2 (cl_object);
cl_object qrun_on_ui_thread2 (cl_object, cl_object);
cl_object qget2 (cl_object, cl_object);
@ -81,6 +82,7 @@ cl_object qversion ();
cl_object qt_object_info (cl_object);
cl_object reload2 ();
cl_object root_item ();
cl_object set_clipboard_text (cl_object);
cl_object set_shutdown_p (cl_object);
void iniCLFunctions();

79
src/cpp/ecl_fun_plugin.h
View file

@ -7,6 +7,7 @@
#undef SLOT
#include <QColor>
#include <QUrl>
#include <QVariant>
#include <QObject>
@ -201,6 +202,15 @@ QString toQString(cl_object l_str) {
return s;
}
QObject* toQObjectPointer(cl_object l_obj) {
STATIC_SYMBOL_PKG (s_qt_object_p, "QT-OBJECT-P", "QML")
STATIC_SYMBOL_PKG (s_qt_object_address, "QT-OBJECT-ADDRESS", "QML")
if (cl_funcall(2, s_qt_object_p, l_obj) != ECL_NIL) {
return reinterpret_cast<QObject*>(toUInt<quintptr>(cl_funcall(2, s_qt_object_address, l_obj)));
}
return nullptr;
}
TO_QT_2 (QPoint, toInt)
TO_QT_2 (QSize, toInt)
TO_QT_4 (QRect, toInt)
@ -217,6 +227,7 @@ QVariant toQVariant(cl_object l_arg, int type) {
QVariant var;
switch (type) {
case QMetaType::QByteArray: var = toQByteArray(l_arg); break;
case QMetaType::QColor: var = QColor(toQString(l_arg)); break;
case QMetaType::QPoint: var = toQPoint(l_arg); break;
case QMetaType::QPointF: var = toQPointF(l_arg); break;
case QMetaType::QRect: var = toQRect(l_arg); break;
@ -224,6 +235,11 @@ QVariant toQVariant(cl_object l_arg, int type) {
case QMetaType::QSize: var = toQSize(l_arg); break;
case QMetaType::QSizeF: var = toQSizeF(l_arg); break;
case QMetaType::QUrl: var = QUrl(toQString(l_arg)); break;
case QMetaType::QObjectStar: {
QObject* o = toQObjectPointer(l_arg);
var = QVariant::fromValue<QObject*>(o); // QObject*
}
break;
default:
if (cl_integerp(l_arg) == ECL_T) { // int
var = QVariant(toInt(l_arg));
@ -231,6 +247,8 @@ QVariant toQVariant(cl_object l_arg, int type) {
var = QVariant(toFloat<double>(l_arg));
} else if (cl_stringp(l_arg) == ECL_T) { // string
var = QVariant(toQString(l_arg));
} else if (cl_characterp(l_arg) == ECL_T) { // char
var = QChar(toInt(cl_char_code(l_arg)));
} else if (l_arg == ECL_T) { // true
var = QVariant(true);
} else if (l_arg == ECL_NIL) { // false
@ -241,8 +259,13 @@ QVariant toQVariant(cl_object l_arg, int type) {
: toQVariantList(l_arg);
} else if (cl_vectorp(l_arg) == ECL_T) { // vector (of octets)
var = QVariant(toQByteArray(l_arg));
} else { // default: undefined
var = QVariant();
} else {
QObject* o = toQObjectPointer(l_arg);
if (o != nullptr) {
var = QVariant::fromValue<QObject*>(o); // e.g. QQuickItem*
} else {
var = QVariant(); // default: undefined
}
}
}
return var;
@ -293,6 +316,25 @@ cl_object from_cstring(const QByteArray& s) {
return l_s;
}
static cl_object make_vector() {
STATIC_SYMBOL_PKG (s_make_vector, "%MAKE-VECTOR", "QML")
cl_object l_vector = cl_funcall(1, s_make_vector);
return l_vector;
}
cl_object from_qbytearray(const QByteArray& ba) {
cl_object l_vec = make_vector();
for (int i = 0; i < ba.size(); i++) {
cl_vector_push_extend(2, ecl_make_fixnum(ba.at(i)), l_vec);
}
return l_vec;
}
cl_object from_qchar(const QChar& ch) {
cl_object l_char = cl_code_char(ecl_make_fixnum(ch.unicode()));
return l_char;
}
cl_object from_qstring(const QString& s) {
cl_object l_s = ecl_alloc_simple_extended_string(s.length());
ecl_character* l_p = l_s->string.self;
@ -302,6 +344,13 @@ cl_object from_qstring(const QString& s) {
return l_s;
}
cl_object from_qobject_pointer(QObject* qobject) {
STATIC_SYMBOL_PKG (s_qt_object, "QT-OBJECT", "QML")
return cl_funcall(2,
s_qt_object,
ecl_make_unsigned_integer(reinterpret_cast<quintptr>(qobject)));
}
TO_CL_2 (QPoint, qpoint, ecl_make_fixnum, x, y)
TO_CL_2 (QSize, qsize, ecl_make_fixnum, width, height)
TO_CL_4 (QRect, qrect, ecl_make_fixnum, x, y, width, height)
@ -317,12 +366,22 @@ cl_object from_qvariant(const QVariant& var) {
#else
const int type = var.typeId();
#endif
if ((type == QMetaType::QObjectStar) || // QObject*
(type >= QMetaType::User)) { // e.g. QQuickItem*
QObject* o = var.value<QObject*>();
if (o != nullptr) {
l_obj = from_qobject_pointer(o);
}
} else {
switch (type) {
case QMetaType::Bool: l_obj = var.toBool() ? ECL_T : ECL_NIL; break;
case QMetaType::Double: l_obj = ecl_make_doublefloat(var.toDouble()); break;
case QMetaType::Int: l_obj = ecl_make_integer(var.toInt()); break;
case QMetaType::UInt: l_obj = ecl_make_unsigned_integer(var.toUInt()); break;
case QMetaType::ULongLong: l_obj = ecl_make_unsigned_integer(var.toULongLong()); break;
case QMetaType::QByteArray: l_obj = from_qbytearray(var.toByteArray()); break;
case QMetaType::QChar: l_obj = from_qchar(var.toChar()); break;
case QMetaType::QColor: l_obj = from_qstring(var.value<QColor>().name()); break;
case QMetaType::QPoint: l_obj = from_qpoint(var.toPoint()); break;
case QMetaType::QPointF: l_obj = from_qpointf(var.toPointF()); break;
case QMetaType::QRect: l_obj = from_qrect(var.toRect()); break;
@ -340,9 +399,12 @@ cl_object from_qvariant(const QVariant& var) {
l_obj = cl_nreverse(l_obj);
break;
}
}
return l_obj;
}
// ecl_fun()
QHash<QByteArray, void*> lisp_functions;
cl_object lisp_apply(cl_object l_fun, cl_object l_args) {
@ -454,4 +516,17 @@ QVariant ecl_fun(const QByteArray& pkgFun,
return QVariant();
}
// Lisp 'qt-object', '%make-vector'
static const char* lisp_code =
"(in-package :cl-user)\n"
"(make-package :qml (use :cl))\n"
"(in-package :qml)\n"
"(defun %make-vector () (make-array 0 :adjustable t :fill-pointer t))\n"
"(defstruct (qt-object (:constructor qt-object (address))) (address 0 :type integer))";
void ini_lisp() {
si_safe_eval(2, ecl_read_from_cstring((char*)lisp_code), ECL_NIL);
}
QT_END_NAMESPACE

2
src/cpp/lqml.cpp
View file

@ -7,7 +7,7 @@
#include <QQuickView>
#include <QDebug>
const char LQML::version[] = "22.3.5"; // Mar 2022
const char LQML::version[] = "22.4.1"; // Apr 2022
extern "C" void ini_LQML(cl_object);

11
src/cpp/marshal.cpp
View file

@ -1,4 +1,5 @@
#include "marshal.h"
#include <QColor>
#include <QUrl>
#include <QVariant>
#include <QObject>
@ -153,6 +154,7 @@ QVariant toQVariant(cl_object l_arg, int type) {
QVariant var;
switch (type) {
case QMetaType::QByteArray: var = toQByteArray(l_arg); break;
case QMetaType::QColor: var = QColor(toQString(l_arg)); break;
case QMetaType::QPoint: var = toQPoint(l_arg); break;
case QMetaType::QPointF: var = toQPointF(l_arg); break;
case QMetaType::QRect: var = toQRect(l_arg); break;
@ -172,6 +174,8 @@ QVariant toQVariant(cl_object l_arg, int type) {
var = QVariant(toFloat<double>(l_arg));
} else if (cl_stringp(l_arg) == ECL_T) { // string
var = QVariant(toQString(l_arg));
} else if (cl_characterp(l_arg) == ECL_T) { // char
var = QChar(toInt(cl_char_code(l_arg)));
} else if (l_arg == ECL_T) { // true
var = QVariant(true);
} else if (l_arg == ECL_NIL) { // false
@ -269,6 +273,11 @@ cl_object from_qbytearray(const QByteArray& ba) {
return l_vec;
}
cl_object from_qchar(const QChar& ch) {
cl_object l_char = cl_code_char(ecl_make_fixnum(ch.unicode()));
return l_char;
}
cl_object from_qstring(const QString& s) {
cl_object l_s = ecl_alloc_simple_extended_string(s.length());
ecl_character* l_p = l_s->string.self;
@ -316,6 +325,8 @@ cl_object from_qvariant(const QVariant& var) {
case QMetaType::UInt: l_obj = ecl_make_unsigned_integer(var.toUInt()); break;
case QMetaType::ULongLong: l_obj = ecl_make_unsigned_integer(var.toULongLong()); break;
case QMetaType::QByteArray: l_obj = from_qbytearray(var.toByteArray()); break;
case QMetaType::QChar: l_obj = from_qchar(var.toChar()); break;
case QMetaType::QColor: l_obj = from_qstring(var.value<QColor>().name()); break;
case QMetaType::QPoint: l_obj = from_qpoint(var.toPoint()); break;
case QMetaType::QPointF: l_obj = from_qpointf(var.toPointF()); break;
case QMetaType::QRect: l_obj = from_qrect(var.toRect()); break;

1
src/cpp/marshal.h
View file

@ -90,6 +90,7 @@ QObject* toQObjectPointer(cl_object);
cl_object from_cstring(const QByteArray&);
cl_object from_qbytearray(const QByteArray&);
cl_object from_qchar(const QChar&);
cl_object from_qstring(const QString&);
cl_object from_qstringlist(const QStringList&);
cl_object from_qvariant(const QVariant&);

2
src/lisp/ecl-ext.lisp
View file

@ -2,6 +2,7 @@
(in-package :qml)
(defun clipboard-text ())
(defun %ensure-permissions (a))
(defun %js (a b))
(defun pixel-ratio ())
@ -33,4 +34,5 @@
(defun qt-object-info (a))
(defun %reload ())
(defun root-item ())
(defun set-clipboard-text (a))
(defun %set-shutdown-p (a))

31
src/lisp/ini.lisp
View file

@ -38,6 +38,14 @@
"NULL"
(format nil "0x~X" address))))))
(defun qeql (object-1 object-2)
"args: (qt-object-1 qt-object-2)
Returns T if passed QT-OBJECTs are pointer equal."
(assert (and (qt-object-p object-1)
(qt-object-p object-2)))
(= (qt-object-address object-1)
(qt-object-address object-2)))
(defmacro ! (fun qt-object &rest args)
;; legacy, should not be needed, use DEFINE-QT-WRAPPERS instead
;; usage:
@ -157,10 +165,7 @@
(define-qt-wrappers *c++* :methods) ; Qt methods only (no slots/signals)
(my-qt-function *c++* x y) ; call from Lisp"
(assert (qt-object-p qt-library))
(let ((all-functions (qapropos* nil qt-library))
(lispify (not (find :do-not-lispify what))))
(setf what (remove-if (lambda (x) (find x '(:do-not-lispify t)))
what))
(let ((all-functions (qapropos* nil qt-library)))
(unless what
(setf what '(:methods :slots :signals)))
(dolist (functions (loop :for el :in what :collect
@ -170,16 +175,19 @@
:key 'first :test 'string=)))
(let* ((p (position #\( fun))
(qt-name (subseq fun (1+ (position #\Space fun :from-end t :end p)) p))
(lisp-name (intern (if lispify
(with-output-to-string (s)
(x:do-string (ch qt-name)
(qt-name* (let ((name (copy-seq qt-name)))
(when (x:ends-with "2" name)
(setf (char name (1- (length name)))
#\*))
name))
(lisp-name (intern (with-output-to-string (s)
(x:do-string (ch qt-name*)
(cond ((upper-case-p ch)
(format s "-~C" ch))
((char= #\_ ch)
(write-char #\- s))
(t
(write-char (char-upcase ch) s)))))
qt-name))))
(write-char (char-upcase ch) s))))))))
;; there seems to be no simple way to avoid EVAL here
;; (excluding non-portable hacks)
(eval `(defgeneric ,lisp-name (object &rest arguments)))
@ -205,6 +213,9 @@
x))
arguments))))))
(defun qprocess-events (&optional exclude-user-input)
(%qprocess-events exclude-user-input))
(defun exec-with-qt-restart ()
;; for internal use; for conditions in Slime during Qt event loop processing
(loop (with-simple-restart (restart-qt-events "Restart Qt event processing.")
@ -317,7 +328,7 @@
;;; alias
(defmacro alias (s1 s2)
`(setf (symbol-function ',s1) (function ,s2)))
`(setf (fdefinition ',s1) (function ,s2)))
(alias qfun qinvoke-method)
(alias qrun qrun-on-ui-thread)

3
src/lisp/package.lisp
View file

@ -6,6 +6,7 @@
#:*engine*
#:*root-item*
#:*caller*
#:clipboard-text
#:define-qt-wrappers
#:ensure-permissions
#:find-quick-item
@ -15,6 +16,7 @@
#:qchildren
#:qcopy-file
#:qdirectory
#:qeql
#:qfind-child
#:qml-call
#:qml-get
@ -51,6 +53,7 @@
#:qt-object-p
#:reload
#:root-item
#:set-clipboard-text
#:tr
#:view-status-changed
#:!))