hsqml 0.1.1 → 0.2.0.0
raw patch · 37 files changed
+3211/−1016 lines, 37 filesdep +QuickCheckdep ~containersdep ~directorydep ~hsqml
Dependencies added: QuickCheck
Dependency ranges changed: containers, directory, hsqml, network, tagged
Files
- CHANGELOG +25/−0
- cbits/HsQMLClass.cpp +56/−23
- cbits/HsQMLClass.h +12/−14
- cbits/HsQMLEngine.cpp +52/−12
- cbits/HsQMLEngine.h +35/−8
- cbits/HsQMLIntrinsics.cpp +2/−2
- cbits/HsQMLManager.cpp +272/−36
- cbits/HsQMLManager.h +86/−19
- cbits/HsQMLObject.cpp +167/−37
- cbits/HsQMLObject.h +31/−5
- cbits/HsQMLWindow.cpp +13/−10
- cbits/HsQMLWindow.h +7/−7
- cbits/hsqml.h +35/−5
- hsqml.cabal +41/−27
- src/Graphics/QML/Debug.hs +1/−1
- src/Graphics/QML/Engine.hs +154/−28
- src/Graphics/QML/Internal/BindCore.chs +82/−0
- src/Graphics/QML/Internal/BindObj.chs +156/−0
- src/Graphics/QML/Internal/BindPrim.chs +77/−0
- src/Graphics/QML/Internal/Engine.chs +0/−48
- src/Graphics/QML/Internal/JobQueue.hs +25/−0
- src/Graphics/QML/Internal/Marshal.hs +92/−28
- src/Graphics/QML/Internal/Objects.chs +0/−143
- src/Graphics/QML/Internal/Objects.hs +122/−0
- src/Graphics/QML/Internal/PrimValues.chs +0/−82
- src/Graphics/QML/Marshal.hs +87/−82
- src/Graphics/QML/Objects.hs +440/−260
- test/Graphics/QML/Test/Framework.hs +277/−0
- test/Graphics/QML/Test/GenURI.hs +51/−0
- test/Graphics/QML/Test/Harness.hs +75/−0
- test/Graphics/QML/Test/MayGen.hs +33/−0
- test/Graphics/QML/Test/MixedTest.hs +75/−0
- test/Graphics/QML/Test/ScriptDSL.hs +130/−0
- test/Graphics/QML/Test/SignalTest.hs +195/−0
- test/Graphics/QML/Test/SimpleTest.hs +259/−0
- test/Graphics/QML/Test/TestObject.hs +33/−0
- test/Test1.hs +13/−139
+ CHANGELOG view
@@ -0,0 +1,25 @@+HsQML - Release History++release-0.2.0.0 - 2013.10.08++ * Added support for firing QML signals.+ * Added dynamic object references.+ * Added MacOS support.+ * Added QuickCheck-based test suite.+ * Added envionment variable to control logging.+ * New design for marshalling type-classes.+ * New API for Engine management.+ * Relexed Cabal dependency constraints.+ * Fixed linking problem on some Linux systems.+ * Fixed support for non-threaded RTS.+ * Fixed various object lifetime issues.+ * Fixed crash in property marshaller.+ * Fixed crash in logging code.++release-0.1.1 - 2012.09.11++ * Fix running test suite on Windows.++release-0.1.0 - 2012.09.10++ * Initial release.
cbits/HsQMLClass.cpp view
@@ -1,35 +1,47 @@ #include <cstdlib> #include <HsFFI.h>-#include <QAtomicInt>-#include <QMetaObject>-#include <QString>-#include <QDebug>+#include <QtCore/QMetaObject>+#include <QtCore/QMetaType>+#include <QtCore/QString> #include "hsqml.h" #include "HsQMLClass.h" #include "HsQMLManager.h" -QAtomicInt gClassId;+enum MDFields {+ MD_METHOD_COUNT = 4,+ MD_PROPERTY_COUNT = 6,+}; +static const char* cRefSrcNames[] = {"Hndl", "Proxy"};+ HsQMLClass::HsQMLClass( unsigned int* metaData, char* metaStrData,+ HsStablePtr hsTypeRep, HsQMLUniformFunc* methods, HsQMLUniformFunc* properties) : mRefCount(0) , mMetaData(metaData) , mMetaStrData(metaStrData)- , mMethods(methods)- , mProperties(properties)+ , mHsTypeRep(hsTypeRep) , mMethodCount(metaData[MD_METHOD_COUNT]) , mPropertyCount(metaData[MD_PROPERTY_COUNT])- , mMetaObject(QMetaObject {{+ , mMethods(methods)+ , mProperties(properties)+{+ // Create meta-object+ QMetaObject tmp = { &QObject::staticMetaObject, mMetaStrData, mMetaData,- 0}})-{+ 0};+ mMetaObject = new QMetaObject(tmp);++ // Add reference ref(Handle);++ gManager->updateCounter(HsQMLManager::ClassCount, 1); } HsQMLClass::~HsQMLClass()@@ -42,17 +54,36 @@ gManager->freeFun((HsFunPtr)mProperties[i]); } }+ gManager->freeStable(mHsTypeRep); std::free(mMetaData); std::free(mMetaStrData); std::free(mMethods); std::free(mProperties);+ delete mMetaObject;++ gManager->updateCounter(HsQMLManager::ClassCount, -1); } const char* HsQMLClass::name() {- return mMetaObject.className();+ return mMetaObject->className(); } +HsStablePtr HsQMLClass::hsTypeRep()+{+ return mHsTypeRep;+}++int HsQMLClass::methodCount()+{+ return mMethodCount;+}++int HsQMLClass::propertyCount()+{+ return mPropertyCount;+}+ const HsQMLUniformFunc* HsQMLClass::methods() { return mMethods;@@ -63,26 +94,27 @@ return mProperties; } +const QMetaObject* HsQMLClass::metaObj()+{+ return mMetaObject;+}+ void HsQMLClass::ref(RefSrc src) { int count = mRefCount.fetchAndAddOrdered(1); - if (gLogLevel >= (count == 0 ? 1 : 2)) {- qDebug() << QString().sprintf(- "HsQML: %s Class, name=%s, src=%d, count=%d.",- count ? "Ref" : "New", name(), src, count+1);- }+ HSQML_LOG(count == 0 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count ? "Ref" : "New", name(), cRefSrcNames[src], count+1)); } void HsQMLClass::deref(RefSrc src) { int count = mRefCount.fetchAndAddOrdered(-1); - if (gLogLevel >= (count == 1 ? 1 : 2)) {- qDebug() << QString().sprintf(- "HsQML: %s Class, name=%s, src=%d, count=%d.",- count > 1 ? "Deref" : "Delete", name(), src, count);- }+ HSQML_LOG(count == 1 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count)); if (count == 1) { delete this;@@ -91,17 +123,18 @@ extern "C" int hsqml_get_next_class_id() {- return gClassId.fetchAndAddRelaxed(1);+ return gManager->updateCounter(HsQMLManager::ClassSerial, 1); } extern "C" HsQMLClassHandle* hsqml_create_class( unsigned int* metaData, char* metaStrData,+ HsStablePtr hsTypeRep, HsQMLUniformFunc* methods, HsQMLUniformFunc* properties) { HsQMLClass* klass = new HsQMLClass(- metaData, metaStrData, methods, properties);+ metaData, metaStrData, hsTypeRep, methods, properties); return (HsQMLClassHandle*)klass; }
cbits/HsQMLClass.h view
@@ -1,26 +1,25 @@ #ifndef HSQML_CLASS_H #define HSQML_CLASS_H -#include <QObject>-#include <QAtomicInt>+#include <QtCore/QObject>+#include <QtCore/QAtomicInt> #include "hsqml.h" -enum MDFields {- MD_CLASS_NAME = 1,- MD_METHOD_COUNT = 4,- MD_PROPERTY_COUNT = 6,-};- class HsQMLClass { public: HsQMLClass(- unsigned int*, char*, HsQMLUniformFunc*, HsQMLUniformFunc*);+ unsigned int*, char*, HsStablePtr,+ HsQMLUniformFunc*, HsQMLUniformFunc*); ~HsQMLClass(); const char* name();+ HsStablePtr hsTypeRep();+ int methodCount();+ int propertyCount(); const HsQMLUniformFunc* methods(); const HsQMLUniformFunc* properties();+ const QMetaObject* metaObj(); enum RefSrc {Handle, ObjProxy}; void ref(RefSrc); void deref(RefSrc);@@ -29,13 +28,12 @@ QAtomicInt mRefCount; unsigned int* mMetaData; char* mMetaStrData;+ HsStablePtr mHsTypeRep;+ int mMethodCount;+ int mPropertyCount; HsQMLUniformFunc* mMethods; HsQMLUniformFunc* mProperties;--public:- const int mMethodCount;- const int mPropertyCount;- const QMetaObject mMetaObject;+ QMetaObject* mMetaObject; }; #endif /*HSQML_CLASS_H*/
cbits/HsQMLEngine.cpp view
@@ -1,43 +1,84 @@-#include "hsqml.h" #include "HsQMLManager.h" #include "HsQMLEngine.h" #include "HsQMLObject.h" #include "HsQMLWindow.h" -HsQMLEngine::HsQMLEngine(HsQMLEngineConfig& config)+HsQMLScriptHack::HsQMLScriptHack(QDeclarativeEngine* declEng)+ : mEngine(NULL) {+ QDeclarativeEngine::setObjectOwnership(+ this, QDeclarativeEngine::CppOwnership);+ QDeclarativeExpression expr(declEng->rootContext(), this, "hack(self());");+ expr.evaluate();+ Q_ASSERT(!expr.hasError());+}++QObject* HsQMLScriptHack::self()+{+ return this;+}++void HsQMLScriptHack::hack(QScriptValue value)+{+ mEngine = value.engine();+}++QScriptEngine* HsQMLScriptHack::scriptEngine() const+{+ return mEngine;+}++HsQMLEngine::HsQMLEngine(const HsQMLEngineConfig& config)+ : mScriptEngine(HsQMLScriptHack(&mDeclEngine).scriptEngine())+ , mStopCb(config.stopCb)+{ // Obtain, re-parent, and set QML global object if (config.contextObject) {- QObject* contextObject = config.contextObject->object();- contextObject->setParent(this);- mEngine.rootContext()->setContextObject(contextObject);+ mContextObj.reset(config.contextObject->object(this));+ mDeclEngine.rootContext()->setContextObject(mContextObj.data()); } // Create window HsQMLWindow* win = new HsQMLWindow(this);+ win->setParent(this); win->setSource(config.initialURL); win->setVisible(config.showWindow); if (config.setWindowTitle) { win->setTitle(config.windowTitle); }- mWindows.insert(win); } HsQMLEngine::~HsQMLEngine() {+ // Call stop callback+ mStopCb();+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mStopCb)); } -QDeclarativeEngine* HsQMLEngine::engine()+void HsQMLEngine::childEvent(QChildEvent* ev) {- return &mEngine;+ if (ev->removed() && children().size() == 0) {+ deleteLater();+ } } +QDeclarativeEngine* HsQMLEngine::declEngine()+{+ return &mDeclEngine;+}++QScriptEngine* HsQMLEngine::scriptEngine()+{+ return mScriptEngine;+}+ extern "C" void hsqml_create_engine( HsQMLObjectHandle* contextObject, HsQMLUrlHandle* initialURL, int showWindow, int setWindowTitle,- HsQMLStringHandle* windowTitle)+ HsQMLStringHandle* windowTitle,+ HsQMLTrivialCb stopCb) { HsQMLEngineConfig config; config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);@@ -47,9 +88,8 @@ config.setWindowTitle = true; config.windowTitle = *reinterpret_cast<QString*>(windowTitle); }+ config.stopCb = stopCb; Q_ASSERT (gManager);- QMetaObject::invokeMethod(- gManager, "createEngine", Qt::QueuedConnection,- Q_ARG(HsQMLEngineConfig, config));+ gManager->createEngine(config); }
cbits/HsQMLEngine.h view
@@ -1,11 +1,16 @@ #ifndef HSQML_ENGINE_H #define HSQML_ENGINE_H -#include <QSet>-#include <QString>-#include <QUrl>-#include <QDeclarativeEngine>+#include <QtCore/QScopedPointer>+#include <QtCore/QString>+#include <QtCore/QUrl>+#include <QtScript/QScriptEngine>+#include <QtScript/QScriptValue>+#include <QtDeclarative/QDeclarativeEngine>+#include <QtDeclarative/QDeclarativeExpression> +#include "hsqml.h"+ class HsQMLObjectProxy; class HsQMLWindow; @@ -15,6 +20,7 @@ : contextObject(NULL) , showWindow(false) , setWindowTitle(false)+ , stopCb(NULL) {} HsQMLObjectProxy* contextObject;@@ -22,20 +28,41 @@ bool showWindow; bool setWindowTitle; QString windowTitle;+ HsQMLTrivialCb stopCb; }; +class HsQMLScriptHack : public QObject+{+ Q_OBJECT++public:+ HsQMLScriptHack(QDeclarativeEngine*);+ Q_INVOKABLE virtual QObject* self();+ Q_INVOKABLE virtual void hack(QScriptValue);+ QScriptEngine* scriptEngine() const;++private:+ QScriptEngine* mEngine;+};+ class HsQMLEngine : public QObject { Q_OBJECT public:- HsQMLEngine(HsQMLEngineConfig&);+ HsQMLEngine(const HsQMLEngineConfig&); ~HsQMLEngine();- QDeclarativeEngine* engine();+ virtual void childEvent(QChildEvent*);+ QDeclarativeEngine* declEngine();+ QScriptEngine* scriptEngine(); private:- QDeclarativeEngine mEngine;- QSet<HsQMLWindow*> mWindows;+ Q_DISABLE_COPY(HsQMLEngine)++ QDeclarativeEngine mDeclEngine;+ QScriptEngine* mScriptEngine;+ QScopedPointer<QObject> mContextObj;+ HsQMLTrivialCb mStopCb; }; #endif /*HSQML_ENGINE_H*/
cbits/HsQMLIntrinsics.cpp view
@@ -1,8 +1,8 @@ #include <cstdlib> #include <cstring> -#include <QString>-#include <QUrl>+#include <QtCore/QString>+#include <QtCore/QUrl> #include "hsqml.h"
cbits/HsQMLManager.cpp view
@@ -1,38 +1,87 @@-#include <QMetaType>+#include <iostream>+#include <cstdlib>+#include <QtCore/QBasicTimer>+#include <QtCore/QMetaType>+#include <QtCore/QMutexLocker>+#include <QtCore/QThread> #include "HsQMLManager.h"+#include "HsQMLObject.h" -QMutex gMutex;-HsQMLManager* gManager;-int gLogLevel;+static const char* cCounterNames[] = {+ "ClassCounter",+ "ObjectCounter",+ "QObjectCounter",+ "ClassSerial",+ "ObjectSerial"+}; +extern "C" void hsqml_dump_counters()+{+ Q_ASSERT (gManager);+ if (gManager->checkLogLevel(1)) {+ for (int i=0; i<HsQMLManager::TotalCounters; i++) {+ gManager->log(QString().sprintf("%s = %d.",+ cCounterNames[i], gManager->updateCounter(+ static_cast<HsQMLManager::CounterId>(i), 0)));+ }+ }+}++QAtomicPointer<HsQMLManager> gManager;+ HsQMLManager::HsQMLManager(- int& argc,- char** argv, void (*freeFun)(HsFunPtr), void (*freeStable)(HsStablePtr))- : mApp(argc, argv)+ : mLogLevel(0)+ , mAtExit(false) , mFreeFun(freeFun) , mFreeStable(freeStable)+ , mApp(NULL)+ , mLock(QMutex::Recursive)+ , mRunning(false)+ , mRunCount(0)+ , mStartCb(NULL)+ , mJobsCb(NULL)+ , mYieldCb(NULL)+ , mActiveEngine(NULL) {+ qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");++ const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL");+ if (env) {+ setLogLevel(QString(env).toInt());+ } } -HsQMLManager::~HsQMLManager()+void HsQMLManager::setLogLevel(int ll) {+ mLogLevel = ll;+ if (ll > 0 && !mAtExit) {+ if (atexit(&hsqml_dump_counters) == 0) {+ mAtExit = true;+ }+ else {+ log("Failed to register callback with atexit().");+ }+ } } -void HsQMLManager::run()+bool HsQMLManager::checkLogLevel(int ll) {- mApp.exec();+ return mLogLevel >= ll;+} - // Delete engines once the event loop returns- for (QVector<HsQMLEngine*>::iterator it = mEngines.begin();- it != mEngines.end(); ++it) {- delete *it;- }- mEngines.clear();+void HsQMLManager::log(const QString& msg)+{+ std::cerr << "HsQML: " << msg.toStdString() << std::endl; } +int HsQMLManager::updateCounter(CounterId id, int delta)+{+ return mCounters[id].fetchAndAddRelaxed(delta);+}+ void HsQMLManager::freeFun(HsFunPtr funPtr) { mFreeFun(funPtr);@@ -43,36 +92,223 @@ mFreeStable(stablePtr); } -void HsQMLManager::createEngine(HsQMLEngineConfig config)+bool HsQMLManager::isEventThread() {- mEngines.push_back(new HsQMLEngine(config));+ return mApp && mApp->thread() == QThread::currentThread(); } -extern "C" void hsqml_init(- void (*free_fun)(HsFunPtr),- void (*free_stable)(HsStablePtr))+HsQMLManager::EventLoopStatus HsQMLManager::runEventLoop(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb) {- gMutex.lock();- if (!gManager) {- qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");+ QMutexLocker locker(&mLock); - int* argcp = new int[1];- *argcp = 1;- char** argv = new char*[1];- argv[0] = new char[1];- argv[0][0] = '\0';- gManager = new HsQMLManager(*argcp, argv, free_fun, free_stable);+ // Check if already running+ if (mRunning) {+ return HSQML_EVLOOP_ALREADY_RUNNING; }- gMutex.unlock();++ // Check if event loop bound to a different thread+ if (mApp && !isEventThread()) {+ return HSQML_EVLOOP_WRONG_THREAD;+ }++ // Create application object+ if (!mApp) {+ mApp = new HsQMLManagerApp();+ }++ // Save callbacks+ mStartCb = startCb;+ mJobsCb = jobsCb;+ mYieldCb = yieldCb;++ // Setup events+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StartedLoopEvent),+ Qt::HighEventPriority);+ QBasicTimer idleTimer;+ if (yieldCb) {+ idleTimer.start(0, mApp);+ }++ // Run loop+ int ret = mApp->exec();++ // Remove redundant events+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::RemoveGCLockEvent);++ // Cleanup callbacks+ freeFun(startCb);+ mStartCb = NULL;+ freeFun(jobsCb);+ mJobsCb = NULL;+ if (yieldCb) {+ freeFun(yieldCb);+ mYieldCb = NULL;+ }++ // Return+ if (ret == 0) {+ return HSQML_EVLOOP_OK;+ }+ else {+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::StartedLoopEvent);+ return HSQML_EVLOOP_OTHER_ERROR;+ } } -extern "C" void hsqml_run()+HsQMLManager::EventLoopStatus HsQMLManager::requireEventLoop() {- Q_ASSERT (gManager);- gManager->run();+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ mRunCount++;+ return HSQML_EVLOOP_OK;+ }+ else {+ return HSQML_EVLOOP_NOT_RUNNING;+ } } -extern "C" void hsqml_set_debug_loglevel(int level)+void HsQMLManager::releaseEventLoop() {- gLogLevel = level;+ QMutexLocker locker(&mLock);+ if (--mRunCount == 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StopLoopEvent),+ Qt::LowEventPriority);+ }+}++void HsQMLManager::notifyJobs()+{+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::PendingJobsEvent));+ }+}++void HsQMLManager::createEngine(const HsQMLEngineConfig& config)+{+ Q_ASSERT (mApp);+ QMetaObject::invokeMethod(+ mApp, "createEngine", Q_ARG(HsQMLEngineConfig, config));+}++void HsQMLManager::setActiveEngine(HsQMLEngine* engine)+{+ Q_ASSERT(!mActiveEngine || !engine);+ mActiveEngine = engine;+}++HsQMLEngine* HsQMLManager::activeEngine()+{+ return mActiveEngine;+}++void HsQMLManager::postObjectEvent(HsQMLObjectEvent* ev)+{+ QCoreApplication::postEvent(mApp, ev);+}++HsQMLManagerApp::HsQMLManagerApp()+ : mArgC(1)+ , mArg0(0)+ , mArgV(&mArg0)+ , mApp(mArgC, &mArgV)+{+ mApp.setQuitOnLastWindowClosed(false);+}++HsQMLManagerApp::~HsQMLManagerApp()+{}++void HsQMLManagerApp::customEvent(QEvent* ev)+{+ switch (ev->type()) {+ case HsQMLManagerApp::StartedLoopEvent: {+ gManager->mRunning = true;+ gManager->mRunCount++;+ gManager->mLock.unlock();+ gManager->mStartCb();+ gManager->mJobsCb();+ break;}+ case HsQMLManagerApp::StopLoopEvent: {+ gManager->mLock.lock();+ const QObjectList& cs = gManager->mApp->children();+ while (!cs.empty()) {+ delete cs.front();+ }+ gManager->mRunning = false;+ gManager->mApp->mApp.quit();+ break;}+ case HsQMLManagerApp::PendingJobsEvent: {+ gManager->mJobsCb();+ break;}+ case HsQMLManagerApp::RemoveGCLockEvent: {+ static_cast<HsQMLObjectEvent*>(ev)->process();+ break;}+ }+}++void HsQMLManagerApp::timerEvent(QTimerEvent*)+{+ Q_ASSERT(gManager->mYieldCb);+ gManager->mYieldCb();+}++void HsQMLManagerApp::createEngine(HsQMLEngineConfig config)+{+ HsQMLEngine* engine = new HsQMLEngine(config);+ engine->setParent(this);+}++int HsQMLManagerApp::exec()+{+ return mApp.exec();+}++extern "C" void hsqml_init(+ void (*freeFun)(HsFunPtr),+ void (*freeStable)(HsStablePtr))+{+ if (gManager == NULL) {+ HsQMLManager* manager = new HsQMLManager(freeFun, freeStable);+ if (!gManager.testAndSetOrdered(NULL, manager)) {+ delete manager;+ }+ }+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_run(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb)+{+ return gManager->runEventLoop(startCb, jobsCb, yieldCb);+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_require()+{+ return gManager->requireEventLoop();+}++extern "C" void hsqml_evloop_release()+{+ gManager->releaseEventLoop();+}++extern "C" void hsqml_evloop_notify_jobs()+{+ gManager->notifyJobs();+}++extern "C" void hsqml_set_debug_loglevel(int ll)+{+ Q_ASSERT (gManager);+ gManager->setLogLevel(ll); }
cbits/HsQMLManager.h view
@@ -1,42 +1,109 @@ #ifndef HSQML_MANAGER_H #define HSQML_MANAGER_H -#include <QApplication>-#include <QMutex>-#include <QVector>-#include <QUrl>+#include <QtCore/QAtomicPointer>+#include <QtCore/QAtomicInt>+#include <QtCore/QMutex>+#include <QtCore/QString>+#include <QtGui/QApplication> #include "hsqml.h" #include "HsQMLEngine.h" -class HsQMLManager : public QObject-{- Q_OBJECT+#define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg) +class HsQMLManagerApp;+class HsQMLObjectEvent;++class HsQMLManager+{ public:+ enum CounterId {+ ClassCount,+ ObjectCount,+ QObjectCount,+ ClassSerial,+ ObjectSerial,+ TotalCounters+ }; + HsQMLManager(- int& argc,- char** argv, void (*)(HsFunPtr), void (*)(HsStablePtr));- ~HsQMLManager();- void run();+ void setLogLevel(int);+ bool checkLogLevel(int);+ void log(const QString&);+ int updateCounter(CounterId, int); void freeFun(HsFunPtr); void freeStable(HsStablePtr);- Q_SLOT void createEngine(HsQMLEngineConfig);+ bool isEventThread();+ typedef HsQMLEventLoopStatus EventLoopStatus;+ EventLoopStatus runEventLoop(+ HsQMLTrivialCb, HsQMLTrivialCb, HsQMLTrivialCb);+ EventLoopStatus requireEventLoop();+ void releaseEventLoop();+ void notifyJobs();+ void createEngine(const HsQMLEngineConfig&);+ void setActiveEngine(HsQMLEngine*);+ HsQMLEngine* activeEngine();+ void postObjectEvent(HsQMLObjectEvent*); private:- HsQMLManager(const HsQMLManager&);- HsQMLManager& operator=(const HsQMLManager&);+ friend class HsQMLManagerApp;+ Q_DISABLE_COPY(HsQMLManager) - QApplication mApp;- QVector<HsQMLEngine*> mEngines;+ int mLogLevel;+ QAtomicInt mCounters[TotalCounters];+ bool mAtExit; void (*mFreeFun)(HsFunPtr); void (*mFreeStable)(HsStablePtr);+ HsQMLManagerApp* mApp;+ QMutex mLock;+ bool mRunning;+ int mRunCount;+ HsQMLTrivialCb mStartCb;+ HsQMLTrivialCb mJobsCb;+ HsQMLTrivialCb mYieldCb;+ HsQMLEngine* mActiveEngine; }; -extern QMutex gMutex;-extern HsQMLManager* gManager;-extern int gLogLevel;+class HsQMLManagerApp : public QObject+{+ Q_OBJECT++public:+ HsQMLManagerApp();+ virtual ~HsQMLManagerApp();+ virtual void customEvent(QEvent*);+ virtual void timerEvent(QTimerEvent*);+ Q_SLOT void createEngine(HsQMLEngineConfig);+ int exec();++ enum CustomEventIndicies {+ StartedLoopEventIndex,+ StopLoopEventIndex,+ PendingJobsEventIndex,+ RemoveGCLockEventIndex+ };++ static const QEvent::Type StartedLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StartedLoopEventIndex);+ static const QEvent::Type StopLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StopLoopEventIndex);+ static const QEvent::Type PendingJobsEvent =+ static_cast<QEvent::Type>(QEvent::User+PendingJobsEventIndex);+ static const QEvent::Type RemoveGCLockEvent =+ static_cast<QEvent::Type>(QEvent::User+RemoveGCLockEventIndex);++private:+ Q_DISABLE_COPY(HsQMLManagerApp)++ int mArgC;+ char mArg0;+ char* mArgV;+ QApplication mApp;+};++extern QAtomicPointer<HsQMLManager> gManager; #endif /*HSQML_MANAGER_H*/
cbits/HsQMLObject.cpp view
@@ -1,25 +1,29 @@ #include <HsFFI.h>-#include <QDeclarativeEngine>-#include <QString>-#include <QDebug>+#include <QtCore/QString>+#include <QtDeclarative/QDeclarativeEngine> #include "HsQMLObject.h" #include "HsQMLClass.h" #include "HsQMLManager.h" +static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event"};+ HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass) : mHaskell(haskell) , mKlass(klass)+ , mSerial(gManager->updateCounter(HsQMLManager::ObjectSerial, 1)) , mObject(NULL) , mRefCount(0) { ref(Handle); mKlass->ref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, 1); } HsQMLObjectProxy::~HsQMLObjectProxy() { mKlass->deref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, -1); } HsStablePtr HsQMLObjectProxy::haskell() const@@ -32,65 +36,145 @@ return mKlass; } -HsQMLObject* HsQMLObjectProxy::object()+HsQMLObject* HsQMLObjectProxy::object(HsQMLEngine* engine) {+ Q_ASSERT(gManager->isEventThread());+ Q_ASSERT(engine); if (!mObject) {- mObject = new HsQMLObject(this);+ mObject = new HsQMLObject(this, engine);+ tryGCLock();++ HSQML_LOG(5,+ QString().sprintf("New QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject)); } return mObject; } void HsQMLObjectProxy::clearObject() {+ Q_ASSERT(gManager->isEventThread());+ mObject = NULL;++ HSQML_LOG(5,+ QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject)); } +void HsQMLObjectProxy::tryGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mHndlCount > 0 && !mObject->isGCLocked()) {+ mObject->setGCLock();++ HSQML_LOG(5,+ QString().sprintf("Lock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+}++void HsQMLObjectProxy::removeGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mHndlCount == 0 && mObject->isGCLocked()) {+ mObject->clearGCLock();++ HSQML_LOG(5,+ QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+}++HsQMLEngine* HsQMLObjectProxy::engine() const+{+ if (mObject != NULL) {+ return mObject->engine();+ }+ return NULL;+}+ void HsQMLObjectProxy::ref(RefSrc src) { int count = mRefCount.fetchAndAddOrdered(1); - if (gLogLevel >= (count == 0 ? 3 : 4)) {- qDebug() << QString().sprintf(- "HsQML: %s ObjProxy, class=%s, ptr=%p, src=%d, count=%d.",- count ? "Ref" : "New", mKlass->name(), this, src, count+1);+ HSQML_LOG(count == 0 ? 3 : 4,+ QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count ? "Ref" : "New", mKlass->name(),+ mSerial, cRefSrcNames[src], count+1));++ if (src == Handle) {+ mHndlCount.fetchAndAddOrdered(1); } } void HsQMLObjectProxy::deref(RefSrc src) {+ // Remove JavaScript GC lock when there are no handles+ if (src == Handle) {+ int hndlCount = mHndlCount.fetchAndAddOrdered(-1);+ if (hndlCount == 1 && mObject) {+ // This will increment the reference count for the lifetime of the+ // of the event.+ gManager->postObjectEvent(new HsQMLObjectEvent(this));+ }+ }+ int count = mRefCount.fetchAndAddOrdered(-1); - if (gLogLevel >= (count == 1 ? 3 : 4)) {- qDebug() << QString().sprintf(- "HsQML: %s ObjProxy, class=%s, ptr=%p, src=%d, count=%d.",- count > 1 ? "Deref" : "Delete", mKlass->name(), this, src, count);- }+ HSQML_LOG(count == 1 ? 3 : 4,+ QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", mKlass->name(),+ mSerial, cRefSrcNames[src], count)); if (count == 1) { delete this; } } -HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy)+HsQMLObjectEvent::HsQMLObjectEvent(HsQMLObjectProxy* proxy)+ : QEvent(HsQMLManagerApp::RemoveGCLockEvent)+ , mProxy(proxy)+{+ mProxy->ref(HsQMLObjectProxy::Event);+}++HsQMLObjectEvent::~HsQMLObjectEvent()+{+ mProxy->deref(HsQMLObjectProxy::Event);+}++void HsQMLObjectEvent::process()+{+ Q_ASSERT(type() == HsQMLManagerApp::RemoveGCLockEvent);+ mProxy->removeGCLock();+}++HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy, HsQMLEngine* engine) : mProxy(proxy) , mHaskell(proxy->haskell()) , mKlass(proxy->klass())+ , mEngine(engine) { QDeclarativeEngine::setObjectOwnership( this, QDeclarativeEngine::JavaScriptOwnership); mProxy->ref(HsQMLObjectProxy::Object);+ gManager->updateCounter(HsQMLManager::QObjectCount, 1); } HsQMLObject::~HsQMLObject() { mProxy->clearObject(); mProxy->deref(HsQMLObjectProxy::Object);+ gManager->updateCounter(HsQMLManager::QObjectCount, -1); } const QMetaObject* HsQMLObject::metaObject() const { return QObject::d_ptr->metaObject ?- QObject::d_ptr->metaObject : &mKlass->mMetaObject;+ QObject::d_ptr->metaObject : mKlass->metaObj(); } void* HsQMLObject::qt_metacast(const char* clname)@@ -98,9 +182,7 @@ if (!clname) { return 0; }- if (!strcmp(clname,- mKlass->mMetaObject.d.stringdata +- mKlass->mMetaObject.d.data[MD_CLASS_NAME])) {+ if (!strcmp(clname, mKlass->metaObj()->className())) { return static_cast<void*>(const_cast<HsQMLObject*>(this)); } return QObject::qt_metacast(clname);@@ -112,36 +194,59 @@ if (id < 0) { return id; }+ gManager->setActiveEngine(mEngine); if (QMetaObject::InvokeMetaMethod == c) { mKlass->methods()[id](this, a);- id -= mKlass->mMethodCount;+ id -= mKlass->methodCount(); } else if (QMetaObject::ReadProperty == c) { mKlass->properties()[2*id](this, a);- id -= mKlass->mPropertyCount;+ id -= mKlass->propertyCount(); } else if (QMetaObject::WriteProperty == c) { HsQMLUniformFunc uf = mKlass->properties()[2*id+1]; if (uf) { uf(this, a); }- id -= mKlass->mPropertyCount;+ id -= mKlass->propertyCount(); } else if (QMetaObject::QueryPropertyDesignable == c || QMetaObject::QueryPropertyScriptable == c || QMetaObject::QueryPropertyStored == c || QMetaObject::QueryPropertyEditable == c || QMetaObject::QueryPropertyUser == c) {- id -= mKlass->mPropertyCount;+ id -= mKlass->propertyCount(); }+ gManager->setActiveEngine(NULL); return id; } +void HsQMLObject::setGCLock()+{+ mGCLock = mEngine->scriptEngine()->newQObject(+ this, QScriptEngine::ScriptOwnership);+}++void HsQMLObject::clearGCLock()+{+ mGCLock = QScriptValue();+}++bool HsQMLObject::isGCLocked() const+{+ return mGCLock.isValid();+}+ HsQMLObjectProxy* HsQMLObject::proxy() const { return mProxy; } +HsQMLEngine* HsQMLObject::engine() const+{+ return mEngine;+}+ extern "C" HsQMLObjectHandle* hsqml_create_object( HsStablePtr haskell, HsQMLClassHandle* kHndl) {@@ -149,6 +254,25 @@ return (HsQMLObjectHandle*)proxy; } +extern "C" void hsqml_object_set_active(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ if (proxy) {+ gManager->setActiveEngine(proxy->engine());+ }+ else {+ gManager->setActiveEngine(NULL);+ }+}++extern "C" HsStablePtr hsqml_object_get_hs_typerep(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ return proxy->klass()->hsTypeRep();+}+ extern HsStablePtr hsqml_object_get_haskell( HsQMLObjectHandle* hndl) {@@ -160,32 +284,23 @@ HsQMLObjectHandle* hndl) { HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return (void*)proxy->object();+ return (void*)proxy->object(gManager->activeEngine()); } extern HsQMLObjectHandle* hsqml_get_object_handle(- void* ptr, HsQMLClassHandle* klassHndl)+ void* ptr) { // Return NULL if the input pointer is NULL if (!ptr) { return NULL; } - // Return NULL if the object type doesn't match any supplied class- if (klassHndl) {- HsQMLClass* klass = (HsQMLClass*)klassHndl;- QObject* qObj = static_cast<QObject*>(ptr);- if (0 != strcmp(- qObj->metaObject()->className(),- klass->mMetaObject.className())) {- return NULL;- }- }-- // Return object proxy+ // Get object proxy HsQMLObject* object = (HsQMLObject*)ptr; HsQMLObjectProxy* proxy = object->proxy(); proxy->ref(HsQMLObjectProxy::Handle);+ proxy->tryGCLock();+ return (HsQMLObjectHandle*)proxy; } @@ -195,5 +310,20 @@ if (hndl) { HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl; proxy->deref(HsQMLObjectProxy::Handle);+ }+}++extern void hsqml_fire_signal(+ HsQMLObjectHandle* hndl, int idx, void** args)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ HsQMLEngine* engine = proxy->engine();+ // Ignore objects which haven't been marshalled as they are not connected.+ if (engine) {+ // Clear active engine in case the slot code calls back into Haskell.+ Q_ASSERT(gManager->activeEngine() == engine);+ gManager->setActiveEngine(NULL);+ HsQMLObject* obj = proxy->object(engine);+ QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args); } }
cbits/HsQMLObject.h view
@@ -1,8 +1,12 @@ #ifndef HSQML_OBJECT_H #define HSQML_OBJECT_H -#include <QObject>+#include <QtCore/QObject>+#include <QtCore/QAtomicInt>+#include <QtCore/QEvent>+#include <QtScript/QScriptValue> +class HsQMLEngine; class HsQMLClass; class HsQMLObject; @@ -13,33 +17,55 @@ virtual ~HsQMLObjectProxy(); HsStablePtr haskell() const; HsQMLClass* klass() const;- HsQMLObject* object();+ HsQMLObject* object(HsQMLEngine*); void clearObject();- enum RefSrc {Handle, Object};+ void tryGCLock();+ void removeGCLock();+ HsQMLEngine* engine() const;+ enum RefSrc {Handle, Object, Event}; void ref(RefSrc); void deref(RefSrc); private: HsStablePtr mHaskell; HsQMLClass* mKlass;- HsQMLObject* mObject;+ int mSerial;+ HsQMLObject* volatile mObject; QAtomicInt mRefCount;+ QAtomicInt mHndlCount; }; +class HsQMLObjectEvent : public QEvent+{+public:+ HsQMLObjectEvent(HsQMLObjectProxy*);+ virtual ~HsQMLObjectEvent();+ void process();++private:+ HsQMLObjectProxy* mProxy;+};+ class HsQMLObject : public QObject { public:- HsQMLObject(HsQMLObjectProxy*);+ HsQMLObject(HsQMLObjectProxy*, HsQMLEngine*); virtual ~HsQMLObject(); virtual const QMetaObject* metaObject() const; virtual void* qt_metacast(const char*); virtual int qt_metacall(QMetaObject::Call, int, void**);+ void setGCLock();+ void clearGCLock();+ bool isGCLocked() const; HsQMLObjectProxy* proxy() const;+ HsQMLEngine* engine() const; private: HsQMLObjectProxy* mProxy; HsStablePtr mHaskell; HsQMLClass* mKlass;+ HsQMLEngine* mEngine;+ QScriptValue mGCLock; }; #endif /*HSQML_OBJECT_H*/
cbits/HsQMLWindow.cpp view
@@ -5,15 +5,16 @@ HsQMLWindow::HsQMLWindow(HsQMLEngine* engine) : QObject(engine) , mEngine(engine)- , mContext(engine->engine())+ , mContext(engine->declEngine()) , mView(&mScene) , mComponent(NULL) { // Setup context mContext.setContextProperty("window", this); - // Don't delete on close+ // Handle Window close event manually mWindow.setAttribute(Qt::WA_DeleteOnClose, false);+ mWindow.installEventFilter(this); // Setup for QML performance mView.setOptimizationFlags(QGraphicsView::DontSavePainterState);@@ -32,6 +33,14 @@ { } +bool HsQMLWindow::eventFilter(QObject* obj, QEvent* ev)+{+ if (obj == &mWindow && ev->type() == QEvent::Close) {+ deleteLater();+ }+ return false;+}+ QUrl HsQMLWindow::source() const { return mSource;@@ -46,7 +55,7 @@ } if (!mSource.isEmpty()) { mComponent = new QDeclarativeComponent(- mEngine->engine(), mSource, this);+ mEngine->declEngine(), mSource, this); if (mComponent->isLoading()) { QObject::connect( mComponent,@@ -94,11 +103,5 @@ void HsQMLWindow::close() {- QMetaObject::invokeMethod(- this, "completeClose", Qt::QueuedConnection);-}--void HsQMLWindow::completeClose()-{- delete this;+ deleteLater(); }
cbits/HsQMLWindow.h view
@@ -1,12 +1,12 @@ #ifndef HSQML_WINDOW_H #define HSQML_WINDOW_H -#include <QMainWindow>-#include <QDeclarativeContext>-#include <QDeclarativeItem>-#include <QGraphicsScene>-#include <QGraphicsView>-#include <QUrl>+#include <QtCore/QUrl>+#include <QtGui/QMainWindow>+#include <QtGui/QGraphicsScene>+#include <QtGui/QGraphicsView>+#include <QtDeclarative/QDeclarativeContext>+#include <QtDeclarative/QDeclarativeItem> #include "HsQMLManager.h" @@ -19,6 +19,7 @@ public: HsQMLWindow(HsQMLEngine*); virtual ~HsQMLWindow();+ virtual bool eventFilter(QObject*, QEvent*); QUrl source() const; void setSource(const QUrl&); Q_PROPERTY(QUrl source READ source WRITE setSource);@@ -32,7 +33,6 @@ private: Q_SLOT void completeSetSource();- Q_SLOT void completeClose(); HsQMLEngine* mEngine; QDeclarativeContext mContext; QMainWindow mWindow;
cbits/hsqml.h view
@@ -13,10 +13,30 @@ void (*)(HsFunPtr), void (*)(HsStablePtr)); -extern void hsqml_run();- extern void hsqml_set_debug_loglevel(int); +/* Event Loop */+typedef void (*HsQMLTrivialCb)();++typedef enum {+ HSQML_EVLOOP_OK = 0,+ HSQML_EVLOOP_ALREADY_RUNNING,+ HSQML_EVLOOP_WRONG_THREAD,+ HSQML_EVLOOP_NOT_RUNNING,+ HSQML_EVLOOP_OTHER_ERROR+} HsQMLEventLoopStatus;++extern HsQMLEventLoopStatus hsqml_evloop_run(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb);++extern HsQMLEventLoopStatus hsqml_evloop_require();++extern void hsqml_evloop_release();++extern void hsqml_evloop_notify_jobs();+ /* String */ typedef char HsQMLStringHandle; @@ -61,7 +81,7 @@ extern int hsqml_get_next_class_id(); extern HsQMLClassHandle* hsqml_create_class(- unsigned int*, char*, HsQMLUniformFunc*, HsQMLUniformFunc*);+ unsigned int*, char*, HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*); extern void hsqml_finalise_class_handle( HsQMLClassHandle* hndl);@@ -72,6 +92,12 @@ extern HsQMLObjectHandle* hsqml_create_object( HsStablePtr, HsQMLClassHandle*); +extern void hsqml_object_set_active(+ HsQMLObjectHandle*);++extern HsStablePtr hsqml_object_get_hs_typerep(+ HsQMLObjectHandle*);+ extern HsStablePtr hsqml_object_get_haskell( HsQMLObjectHandle*); @@ -79,18 +105,22 @@ HsQMLObjectHandle*); extern HsQMLObjectHandle* hsqml_get_object_handle(- void*, HsQMLClassHandle*);+ void*); extern void hsqml_finalise_object_handle( HsQMLObjectHandle*); +extern void hsqml_fire_signal(+ HsQMLObjectHandle*, int, void**);+ /* Engine */ extern void hsqml_create_engine( HsQMLObjectHandle*, HsQMLUrlHandle*, int, int,- HsQMLStringHandle*);+ HsQMLStringHandle*,+ HsQMLTrivialCb stopCb); #ifdef __cplusplus }
hsqml.cabal view
@@ -1,31 +1,41 @@ Name: hsqml-Version: 0.1.1+Version: 0.2.0.0 Cabal-version: >= 1.10 Build-type: Custom License: BSD3 License-file: LICENSE-Copyright: (c) 2010-2012 Robin KAY+Copyright: (c) 2010-2013 Robin KAY Author: Robin KAY Maintainer: komadori@gekkou.co.uk Stability: experimental-Homepage: http://www.gekkou.co.uk/+Homepage: http://www.gekkou.co.uk/software/hsqml/ Category: Graphics Synopsis: Haskell binding for Qt Quick-Extra-source-files: cbits/*.cpp cbits/*.h+Extra-source-files: CHANGELOG cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs Description: A Haskell binding for Qt Quick. General documentation is present in the 'Graphics.QML' module. +Flag UsePkgConfig+ Description:+ Use pkg-config for libraries instead of the platform default mechanism.+ Default: False++Flag ThreadedTestSuite+ Description:+ Build test executable with the threaded RTS.+ Default: True+ Library Default-language: Haskell2010 Build-depends: base == 4.*,- containers == 0.4.*,+ containers >= 0.4 && < 0.6, filepath == 1.3.*,- network == 2.3.*,+ network >= 2.3 && < 2.5, text == 0.11.*,- tagged == 0.4.*,+ tagged >= 0.4 && < 0.8, transformers >= 0.2 && < 0.4 Exposed-modules: Graphics.QML@@ -34,12 +44,13 @@ Graphics.QML.Marshal Graphics.QML.Objects Other-modules:+ Graphics.QML.Internal.BindPrim+ Graphics.QML.Internal.BindObj+ Graphics.QML.Internal.BindCore+ Graphics.QML.Internal.JobQueue Graphics.QML.Internal.Marshal Graphics.QML.Internal.Objects- Graphics.QML.Internal.PrimValues- Graphics.QML.Internal.Engine Hs-source-dirs: src- Cc-options: -std=c++0x C-sources: cbits/HsQMLClass.cpp cbits/HsQMLEngine.cpp@@ -54,19 +65,16 @@ cbits/HsQMLWindow.h X-separate-cbits: True Build-tools: c2hs- if os(windows)- Include-dirs:- /QT_ROOT/include- /QT_ROOT/include/QtCore- /QT_ROOT/include/QtGui- /QT_ROOT/include/QtDeclarative- Extra-libraries: QtCore4, QtGui4, QtDeclarative4, stdc++- Extra-lib-dirs:- /SYS_ROOT/bin- /QT_ROOT/bin+ if os(windows) && !flag(UsePkgConfig)+ Include-dirs: /QT_ROOT/include+ Extra-libraries: QtCore4, QtGui4, QtScript4, QtDeclarative4, stdc+++ Extra-lib-dirs: /SYS_ROOT/bin /QT_ROOT/bin else- Pkgconfig-depends:- QtDeclarative >= 4.7+ if os(darwin) && !flag(UsePkgConfig)+ Frameworks: QtCore QtGui QtScript QtDeclarative+ else+ Pkgconfig-depends: QtScript >= 4.7, QtDeclarative >= 4.7+ Extra-libraries: stdc++ Test-Suite hsqml-test1 Type: exitcode-stdio-1.0@@ -74,11 +82,17 @@ Hs-source-dirs: test Main-is: Test1.hs Build-depends:- base == 4.*,- directory == 1.1.*,- network == 2.3.*,- hsqml == 0.1.*+ base == 4.*,+ containers >= 0.4 && < 0.6,+ directory >= 1.1 && < 1.3,+ network >= 2.3 && < 2.5,+ text == 0.11.*,+ tagged >= 0.4 && < 0.8,+ QuickCheck >= 2.4 && < 2.7,+ hsqml == 0.2.*+ if flag(ThreadedTestSuite)+ GHC-options: -threaded Source-repository head type: darcs- location: https://patch-tag.com/r/komadori/HsQML+ location: http://hub.darcs.net/komadori/HsQML/
src/Graphics/QML/Debug.hs view
@@ -3,7 +3,7 @@ setDebugLogLevel ) where -import Graphics.QML.Internal.Engine+import Graphics.QML.Internal.BindCore -- | Sets the global debug log level. At level zero, no logging information -- will be printed. Higher levels will increase debug verbosity.
src/Graphics/QML/Engine.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE- ExistentialQuantification,- Rank2Types+ DeriveDataTypeable,+ FlexibleContexts,+ GeneralizedNewtypeDeriving #-} -- | Functions for starting QML engines, displaying content in a window. module Graphics.QML.Engine (+ -- * Engines InitialWindowState( ShowWindow, ShowWindowWithTitle,@@ -15,21 +17,39 @@ initialWindowState, contextObject), defaultEngineConfig,- createEngine,- runEngines,+ Engine,+ runEngine,+ runEngineWith,+ runEngineAsync,+ runEngineLoop,++ -- * Event Loop+ RunQML(),+ runEventLoop,+ requireEventLoop,+ EventLoopException(),++ -- * Utilities filePathToURI ) where +import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.Objects-import Graphics.QML.Internal.Engine+import Graphics.QML.Internal.BindCore import Graphics.QML.Marshal import Graphics.QML.Objects +import Control.Applicative+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class import Data.List import Data.Maybe+import Data.Traversable as T import Data.Typeable-import Foreign.Storable import System.FilePath (isAbsolute, splitDirectories, pathSeparators) import Network.URI (URI(URI), URIAuth(URIAuth), nullURI, uriPath) @@ -46,18 +66,18 @@ | HideWindow -- | Holds parameters for configuring a QML runtime engine.-data EngineConfig a = EngineConfig {+data EngineConfig = EngineConfig { -- | URL for the first QML document to be loaded. initialURL :: URI, -- | Window state for the initial QML document. initialWindowState :: InitialWindowState, -- | Context 'Object' made available to QML script code.- contextObject :: Maybe (ObjRef a)+ contextObject :: Maybe AnyObjRef } -- | Default engine configuration. Loads @\"main.qml\"@ from the current -- working directory into a visible window with no context object.-defaultEngineConfig :: EngineConfig a+defaultEngineConfig :: EngineConfig defaultEngineConfig = EngineConfig { initialURL = nullURI {uriPath = "main.qml"}, initialWindowState = ShowWindow,@@ -73,26 +93,132 @@ getWindowTitle (ShowWindowWithTitle t) = Just t getWindowTitle _ = Nothing --- | Create a QML engine from a specification of its configuration.-createEngine :: (Object a) => EngineConfig a -> IO ()-createEngine config = do- hsqmlInit- let hndl = fmap (\(ObjRef h) -> h) $ contextObject config- url = initialURL config- state = initialWindowState config- showWin = isWindowShown state- maybeTitle = getWindowTitle state- setTitle = isJust maybeTitle- titleStr = fromMaybe "" maybeTitle- mOutAlloc url $ \urlPtr -> do- mOutAlloc titleStr $ \titlePtr -> do- hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr+-- | Represents a QML engine.+data Engine = Engine --- | Enters the Qt event loop and runs until all engines have terminated.-runEngines :: IO ()-runEngines = do- hsqmlInit- hsqmlRun+runEngineImpl :: EngineConfig -> IO () -> IO Engine+runEngineImpl config stopCb = do+ hsqmlInit+ let obj = contextObject config+ url = initialURL config+ state = initialWindowState config+ showWin = isWindowShown state+ maybeTitle = getWindowTitle state+ setTitle = isJust maybeTitle+ titleStr = fromMaybe "" maybeTitle+ hndl <- T.sequence $ fmap mHsToObj $ obj+ mHsToAlloc url $ \urlPtr -> do+ mHsToAlloc titleStr $ \titlePtr -> do+ hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr stopCb+ return Engine++-- | Starts a new QML engine using the supplied configuration and blocks until+-- the engine has terminated.+runEngine :: EngineConfig -> RunQML ()+runEngine config = runEngineWith config (const $ return ())++-- | Starts a new QML engine using the supplied configuration. The \'with\'+-- function is executed once the engine has been started and after it returns+-- this function blocks until the engine has terminated.+runEngineWith :: EngineConfig -> (Engine -> RunQML a) -> RunQML a+runEngineWith config with = RunQML $ do+ finishVar <- newEmptyMVar+ let stopCb = putMVar finishVar () + eng <- runEngineImpl config stopCb+ let (RunQML withIO) = with eng+ ret <- withIO+ void $ takeMVar finishVar+ return ret++-- | Starts a new QML engine using the supplied configuration and returns+-- immediately without blocking.+runEngineAsync :: EngineConfig -> RunQML Engine+runEngineAsync config = RunQML $ do+ runEngineImpl config (return ())++-- | Conveniance function that both runs the event loop and starts a new QML+-- engine. It blocks keeping the event loop running until the engine has+-- terminated.+runEngineLoop :: EngineConfig -> IO ()+runEngineLoop config =+ runEventLoop $ runEngine config++-- | Wrapper around the IO monad for running actions which depend on the Qt+-- event loop.+newtype RunQML a = RunQML (IO a) deriving (Functor, Applicative, Monad)++instance MonadIO RunQML where+ liftIO io = RunQML io++-- | This function enters the Qt event loop and executes the supplied function+-- in the 'RunQML' monad on a new unbound thread. The event loop will continue+-- to run until all functions in the 'RunQML' monad have completed. This+-- includes both the 'RunQML' function launched by this call and any launched+-- asynchronously via 'requireEventLoop'. When the event loop exits, all+-- engines will be terminated.+--+-- It's recommended that applications run the event loop on their primordial+-- thread as some platforms mandate this. Once the event loop has finished, it+-- can be started again, but only on the same operating system thread as+-- before. If the event loop fails to start then an 'EventLoopException' will+-- be thrown.+runEventLoop :: RunQML a -> IO a+runEventLoop (RunQML runFn) = tryRunInBoundThread $ do+ hsqmlInit+ finishVar <- newEmptyMVar+ let startCb = void $ forkIO $ do+ ret <- try runFn+ case ret of+ Left ex -> putMVar finishVar $ throwIO (ex :: SomeException)+ Right ret -> putMVar finishVar $ return ret+ hsqmlEvloopRelease+ yieldCb = if rtsSupportsBoundThreads+ then Nothing+ else Just yield+ status <- hsqmlEvloopRun startCb processJobs yieldCb+ case statusException status of+ Just ex -> throw ex+ Nothing -> do + finFn <- takeMVar finishVar+ finFn++tryRunInBoundThread :: IO a -> IO a+tryRunInBoundThread action = do+ if rtsSupportsBoundThreads+ then runInBoundThread action+ else action++-- | Executes a function in the 'RunQML' monad asynchronously to the event+-- loop. Callers must apply their own sychronisation to ensure that the event+-- loop is currently running when this function is called, otherwise an+-- 'EventLoopException' will be thrown. The event loop will not exit until the+-- supplied function has completed.+requireEventLoop :: RunQML a -> IO a+requireEventLoop (RunQML runFn) = do+ hsqmlInit+ let reqFn = do+ status <- hsqmlEvloopRequire+ case statusException status of+ Just ex -> throw ex+ Nothing -> return ()+ bracket_ reqFn hsqmlEvloopRelease runFn++statusException :: HsQMLEventLoopStatus -> Maybe EventLoopException+statusException HsqmlEvloopOk = Nothing+statusException HsqmlEvloopAlreadyRunning = Just EventLoopAlreadyRunning+statusException HsqmlEvloopWrongThread = Just EventLoopWrongThread+statusException HsqmlEvloopNotRunning = Just EventLoopNotRunning+statusException _ = Just EventLoopOtherError++-- | Exception type used to report errors pertaining to the event loop.+data EventLoopException+ = EventLoopAlreadyRunning+ | EventLoopWrongThread+ | EventLoopNotRunning+ | EventLoopOtherError+ deriving (Show, Typeable)++instance Exception EventLoopException -- | Convenience function for converting local file paths into URIs. filePathToURI :: FilePath -> URI
+ src/Graphics/QML/Internal/BindCore.chs view
@@ -0,0 +1,82 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}+{-# OPTIONS_HADDOCK hide #-}++module Graphics.QML.Internal.BindCore where++{#import Graphics.QML.Internal.BindObj #}++import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.StablePtr++#include <HsFFI.h>++#include "hsqml.h"++type HsFreeFunPtr = FunPtr (FunPtr (IO ()) -> IO ())+foreign import ccall "HsFFI.h &hs_free_fun_ptr"+ hsFreeFunPtr :: HsFreeFunPtr++type HsFreeStablePtr = FunPtr (Ptr () -> IO ())+foreign import ccall "HsFFI.h &hs_free_stable_ptr"+ hsFreeStablePtr :: HsFreeStablePtr++{#fun unsafe hsqml_init as hsqmlInit_+ {id `HsFreeFunPtr',+ id `HsFreeStablePtr'} ->+ `()' #}++hsqmlInit :: IO ()+hsqmlInit = hsqmlInit_ hsFreeFunPtr hsFreeStablePtr++type TrivialCb = IO ()++foreign import ccall "wrapper" + marshalTrivialCb :: TrivialCb -> IO (FunPtr TrivialCb)++withTrivialCb :: TrivialCb -> (FunPtr TrivialCb -> IO a) -> IO a+withTrivialCb f with = marshalTrivialCb f >>= with++withMaybeTrivialCb :: Maybe TrivialCb -> (FunPtr TrivialCb -> IO b) -> IO b+withMaybeTrivialCb (Just f) = withTrivialCb f+withMaybeTrivialCb Nothing = \cont -> cont nullFunPtr++{#enum HsQMLEventLoopStatus as ^ {underscoreToCase} #}++cIntToEnum :: Enum a => CInt -> a+cIntToEnum = toEnum . fromIntegral++{#fun hsqml_evloop_run as ^+ {withTrivialCb* `TrivialCb',+ withTrivialCb* `TrivialCb',+ withMaybeTrivialCb* `Maybe TrivialCb'} ->+ `HsQMLEventLoopStatus' cIntToEnum #}++{#fun hsqml_evloop_require as ^+ {} ->+ `HsQMLEventLoopStatus' cIntToEnum #}++{#fun hsqml_evloop_release as ^+ {} ->+ `()' #}++{#fun unsafe hsqml_evloop_notify_jobs as ^+ {} ->+ `()' #}++{#fun hsqml_create_engine as ^+ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle',+ castPtr `Ptr ()',+ fromBool `Bool',+ fromBool `Bool',+ castPtr `Ptr ()',+ withTrivialCb* `TrivialCb'} ->+ `()' #}++{#fun unsafe hsqml_set_debug_loglevel as ^+ {fromIntegral `Int'} -> `()'+ #}
+ src/Graphics/QML/Internal/BindObj.chs view
@@ -0,0 +1,156 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}++module Graphics.QML.Internal.BindObj where++import Control.Exception (bracket_)+import Data.Typeable+import Foreign.C.Types+import Foreign.Ptr+import Foreign.ForeignPtr.Safe+import Foreign.ForeignPtr.Unsafe+import Foreign.StablePtr++#include "hsqml.h"++marshalStable :: a -> (Ptr () -> IO b) -> IO b+marshalStable obj f = do+ sPtr <- newStablePtr obj+ res <- f $ castStablePtrToPtr sPtr+ return res++fromStable :: Ptr () -> IO a+fromStable =+ deRefStablePtr . castPtrToStablePtr++{#fun unsafe hsqml_get_next_class_id as ^+ {} ->+ `CInt' id #}++type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()++foreign import ccall "wrapper" + marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc)++{#pointer *HsQMLClassHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_class_handle"+ hsqmlFinaliseClassHandlePtr :: FunPtr (Ptr (HsQMLClassHandle) -> IO ())++newClassHandle :: Ptr HsQMLClassHandle -> IO (Maybe HsQMLClassHandle)+newClassHandle p =+ if nullPtr == p+ then return Nothing+ else do+ fp <- newForeignPtr hsqmlFinaliseClassHandlePtr p+ return $ Just $ HsQMLClassHandle fp++{#fun unsafe hsqml_create_class as ^+ {id `Ptr CUInt',+ id `Ptr CChar',+ marshalStable* `TypeRep',+ id `Ptr (FunPtr UniformFunc)',+ id `Ptr (FunPtr UniformFunc)'} ->+ `Maybe HsQMLClassHandle' newClassHandle* #}++withMaybeHsQMLObjectHandle ::+ Maybe HsQMLObjectHandle -> (Ptr HsQMLObjectHandle -> IO b) -> IO b+withMaybeHsQMLObjectHandle (Just (HsQMLObjectHandle fp)) = withForeignPtr fp+withMaybeHsQMLObjectHandle Nothing = \f -> f nullPtr++{#pointer *HsQMLObjectHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_object_handle"+ hsqmlFinaliseObjectHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ())++newObjectHandle :: Ptr HsQMLObjectHandle -> IO HsQMLObjectHandle+newObjectHandle p = do+ fp <- newForeignPtr hsqmlFinaliseObjectHandlePtr p+ return $ HsQMLObjectHandle fp++isNullObjectHandle :: HsQMLObjectHandle -> Bool+isNullObjectHandle (HsQMLObjectHandle fp) =+ nullPtr == unsafeForeignPtrToPtr fp++{#fun unsafe hsqml_create_object as ^+ {marshalStable* `a',+ withHsQMLClassHandle* `HsQMLClassHandle'} ->+ `HsQMLObjectHandle' newObjectHandle* #}++{#fun unsafe hsqml_object_set_active as ^+ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle'} ->+ `()' #}++withActiveObject :: HsQMLObjectHandle -> IO () -> IO ()+withActiveObject hndl action =+ bracket_+ (hsqmlObjectSetActive $ Just hndl)+ (hsqmlObjectSetActive Nothing)+ action++{#fun unsafe hsqml_object_get_haskell as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+ `a' fromStable* #}++{#fun unsafe hsqml_object_get_hs_typerep as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+ `TypeRep' fromStable* #}++{#fun unsafe hsqml_object_get_pointer as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+ `Ptr ()' id #}++{#fun unsafe hsqml_get_object_handle as ^+ {id `Ptr ()'} ->+ `HsQMLObjectHandle' newObjectHandle* #}++{#fun hsqml_fire_signal as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle',+ `Int',+ id `Ptr (Ptr ())'} ->+ `()' #}++ofDynamicMetaObject :: CUInt+ofDynamicMetaObject = 0x01++mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask,+ mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor,+ mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable+ :: CUInt+mfAccessPrivate = 0x00+mfAccessProtected = 0x01+mfAccessPublic = 0x02+mfAccessMask = 0x03+mfMethodMethod = 0x00+mfMethodSignal = 0x04+mfMethodSlot = 0x08+mfMethodConstructor = 0x0c+mfMethodTypeMask = 0x0c+mfMethodCompatibility = 0x10+mfMethodCloned = 0x20+mfMethodScriptable = 0x40++pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet,+ pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable,+ pfResolveScriptable, pfStored, pfResolveStored, pfEditable,+ pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt+pfInvalid = 0x00000000+pfReadable = 0x00000001+pfWritable = 0x00000002+pfResettable = 0x00000004+pfEnumOrFlag = 0x00000008+pfStdCppSet = 0x00000100+pfConstant = 0x00000400+pfFinal = 0x00000800+pfDesignable = 0x00001000+pfResolveDesignable = 0x00002000+pfScriptable = 0x00004000+pfResolveScriptable = 0x00008000+pfStored = 0x00010000+pfResolveStored = 0x00020000+pfEditable = 0x00040000+pfResolveEditable = 0x00080000+pfUser = 0x00100000+pfResolveUser = 0x00200000+pfNotify = 0x00400000
+ src/Graphics/QML/Internal/BindPrim.chs view
@@ -0,0 +1,77 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}++module Graphics.QML.Internal.BindPrim where++import Foreign.C.Types+import Foreign.Ptr+import System.IO.Unsafe++#include "hsqml.h"++cIntConv :: (Integral a, Integral b) => a -> b+cIntConv = fromIntegral++--+-- String+--++{#pointer *HsQMLStringHandle as ^ newtype #}++{#fun unsafe hsqml_get_string_size as ^+ {} ->+ `Int' fromIntegral #}++hsqmlStringSize :: Int+hsqmlStringSize = unsafePerformIO $ hsqmlGetStringSize++{#fun unsafe hsqml_init_string as ^+ {id `HsQMLStringHandle'} ->+ `()' #}++{#fun unsafe hsqml_deinit_string as ^+ {id `HsQMLStringHandle'} ->+ `()' #}++{#fun unsafe hsqml_marshal_string as ^+ {`Int',+ id `HsQMLStringHandle'} ->+ `Ptr CUShort' id #}++{#fun unsafe hsqml_unmarshal_string as ^+ {id `HsQMLStringHandle',+ id `Ptr (Ptr CUShort)'} ->+ `Int' #}++--+-- URL+--++{#pointer *HsQMLUrlHandle as ^ newtype #}++{#fun unsafe hsqml_get_url_size as ^+ {} ->+ `Int' fromIntegral #}++hsqmlUrlSize :: Int+hsqmlUrlSize = unsafePerformIO $ hsqmlGetUrlSize++{#fun unsafe hsqml_init_url as ^+ {id `HsQMLUrlHandle'} ->+ `()' #}++{#fun unsafe hsqml_deinit_url as ^+ {id `HsQMLUrlHandle'} ->+ `()' #}++{#fun unsafe hsqml_marshal_url as ^+ {id `Ptr CChar',+ `Int',+ id `HsQMLUrlHandle'} ->+ `()' #}++{#fun unsafe hsqml_unmarshal_url as ^+ {id `HsQMLUrlHandle',+ id `Ptr (Ptr CChar)'} ->+ `Int' #}
− src/Graphics/QML/Internal/Engine.chs
@@ -1,48 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}-{-# OPTIONS_HADDOCK hide #-}--module Graphics.QML.Internal.Engine where--{#import Graphics.QML.Internal.Objects #}--import Foreign.C.Types-import Foreign.C.String-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.StablePtr--#include <HsFFI.h>--#include "hsqml.h"--type HsFreeFunPtr = FunPtr (FunPtr (IO ()) -> IO ())-foreign import ccall "HsFFI.h &hs_free_fun_ptr"- hsFreeFunPtr :: HsFreeFunPtr--type HsFreeStablePtr = FunPtr (Ptr () -> IO ())-foreign import ccall "HsFFI.h &hs_free_stable_ptr"- hsFreeStablePtr :: HsFreeStablePtr--{#fun unsafe hsqml_init as hsqmlInit_- {id `HsFreeFunPtr',- id `HsFreeStablePtr'} ->- `()' #}--hsqmlInit :: IO ()-hsqmlInit = hsqmlInit_ hsFreeFunPtr hsFreeStablePtr--{#fun unsafe hsqml_create_engine as ^- {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle',- castPtr `Ptr ()',- fromBool `Bool',- fromBool `Bool',- castPtr `Ptr ()'} ->- `()' #}--{#fun hsqml_run as ^ {} -> `()' #}--{#fun hsqml_set_debug_loglevel as ^- {fromIntegral `Int'} -> `()'- #}
+ src/Graphics/QML/Internal/JobQueue.hs view
@@ -0,0 +1,25 @@+module Graphics.QML.Internal.JobQueue (+ postJob,+ processJobs+) where++import Graphics.QML.Internal.BindCore++import Control.Concurrent.MVar+import System.IO.Unsafe++{-# NOINLINE jobQueue #-}+jobQueue :: MVar [IO ()]+jobQueue = unsafePerformIO $ newMVar []++postJob :: IO () -> IO ()+postJob j = do+ notify <- modifyMVar jobQueue $ \js -> return (j:js,null js)+ if notify+ then hsqmlEvloopNotifyJobs + else return ()++processJobs :: IO ()+processJobs = do+ js <- modifyMVar jobQueue $ \js -> return ([],js)+ sequence_ $ reverse js
src/Graphics/QML/Internal/Marshal.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE- ScopedTypeVariables+ ScopedTypeVariables,+ TypeFamilies,+ FlexibleContexts,+ FlexibleInstances,+ Rank2Types #-} module Graphics.QML.Internal.Marshal where@@ -15,11 +19,6 @@ typeName :: String } --- | The class 'MarshalIn' allows QML values to be converted into Haskell--- values.-class MarshalIn a where- mIn :: InMarshaller a- type ErrIO a = MaybeT IO a runErrIO :: ErrIO a -> IO ()@@ -32,32 +31,97 @@ errIO :: IO a -> ErrIO a errIO = MaybeT . fmap Just +type MTypeNameFunc t = Tagged t TypeName+type MValToHsFunc t = Ptr () -> ErrIO t+type MHsToValFunc t = t -> Ptr () -> IO ()+type MHsToAllocFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b)++-- | The class 'Marshal' allows Haskell values to be marshalled to and from the+-- QML environment.+class Marshal t where+ -- | The 'MarshalMode' associated type parameter specifies the type of+ -- marshalling functionality offered by the instance.+ type MarshalMode t+ -- | Yields the 'Marshaller' for the type @t@.+ marshaller :: Marshaller t (MarshalMode t)++-- | Base class containing core functionality for all 'MarshalMode's.+class MarshalBase m where+ mTypeName_ :: forall t. Marshaller t m -> MTypeNameFunc t++mTypeName ::+ forall t. (Marshal t, MarshalBase (MarshalMode t)) => MTypeNameFunc t+mTypeName = mTypeName_ (marshaller :: Marshaller t (MarshalMode t))++-- | Class for 'MarshalMode's which support marshalling QML-to-Haskell.+class (MarshalBase m) => MarshalToHs m where+ mValToHs_ :: forall t. Marshaller t m -> MValToHsFunc t++mValToHs ::+ forall t. (Marshal t, MarshalToHs (MarshalMode t)) => MValToHsFunc t+mValToHs = mValToHs_ (marshaller :: Marshaller t (MarshalMode t))++-- | Class for 'MarshalMode's which support marshalling Haskell-to-QML.+class (MarshalBase m) => MarshalToValRaw m where+ mHsToVal_ :: forall t. Marshaller t m -> MHsToValFunc t+ mHsToAlloc_ :: forall t. Marshaller t m -> MHsToAllocFunc t++mHsToVal ::+ forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToValFunc t+mHsToVal = mHsToVal_ (marshaller :: Marshaller t (MarshalMode t))++mHsToAlloc ::+ forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToAllocFunc t+mHsToAlloc = mHsToAlloc_ (marshaller :: Marshaller t (MarshalMode t))++-- | Class for 'MarshalMode's which support marshalling Haskell-to-QML,+-- excluding the return of void from methods.+class (MarshalToValRaw m) => MarshalToVal m where+ -- | Encapsulates the functionality to needed to implement an instance of--- 'MarshalIn' so that such instances can be defined without access to+-- 'Marshal' so that such instances can be defined without access to -- implementation details.-data InMarshaller a = InMarshaller {- mInFuncFld :: Ptr () -> ErrIO a,- mIOTypeFld :: Tagged a TypeName-}+data family Marshaller t m -mInFunc :: (MarshalIn a) => Ptr () -> ErrIO a-mInFunc = mInFuncFld mIn +-- | 'MarshalMode' for built-in data types.+data ValBidi -mIOType :: (MarshalIn a) => Tagged a TypeName-mIOType = mIOTypeFld mIn+data instance Marshaller t ValBidi = MValBidi {+ mValBidi_typeName :: !(MTypeNameFunc t),+ mValBidi_valToHs :: !(MValToHsFunc t),+ mValBidi_hsToVal :: !(MHsToValFunc t),+ mValBidi_hsToAlloc :: !(MHsToAllocFunc t)} --- | The class 'MarshalOut' allows Haskell values to be converted into QML--- values.-class (MarshalIn a) => MarshalOut a where- mOutFunc :: Ptr () -> a -> IO ()- mOutAlloc :: a -> (Ptr () -> IO b) -> IO b+instance MarshalBase ValBidi where+ mTypeName_ = mValBidi_typeName -instance MarshalOut () where- mOutFunc _ _ = return ()- mOutAlloc _ f = f nullPtr+instance MarshalToHs ValBidi where+ mValToHs_ = mValBidi_valToHs -instance MarshalIn () where- mIn = InMarshaller {- mInFuncFld = \_ -> return (),- mIOTypeFld = Tagged $ TypeName ""- }+instance MarshalToValRaw ValBidi where+ mHsToVal_ = mValBidi_hsToVal+ mHsToAlloc_ = mValBidi_hsToAlloc++instance MarshalToVal ValBidi where++-- | 'MarshalMode' for void in method returns.+data ValFnRetVoid++data instance Marshaller t ValFnRetVoid = MValFnRetVoid {+ mValFnRetVoid_typeName :: !(MTypeNameFunc t),+ mValFnRetVoid_hsToVal :: !(MHsToValFunc t),+ mValFnRetVoid_hsToAlloc :: !(MHsToAllocFunc t)}++instance MarshalBase ValFnRetVoid where+ mTypeName_ = mValFnRetVoid_typeName++instance MarshalToValRaw ValFnRetVoid where+ mHsToVal_ = mValFnRetVoid_hsToVal+ mHsToAlloc_ = mValFnRetVoid_hsToAlloc++instance Marshal () where+ type MarshalMode () = ValFnRetVoid+ marshaller = MValFnRetVoid {+ mValFnRetVoid_typeName = Tagged $ TypeName "",+ mValFnRetVoid_hsToVal = \_ _ -> return (),+ mValFnRetVoid_hsToAlloc = \_ f -> f nullPtr}
− src/Graphics/QML/Internal/Objects.chs
@@ -1,143 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}--module Graphics.QML.Internal.Objects where--import Foreign.C.Types-import Foreign.Ptr-import Foreign.ForeignPtr.Safe-import Foreign.ForeignPtr.Unsafe-import Foreign.StablePtr--#include "hsqml.h"--{#fun unsafe hsqml_get_next_class_id as ^- {} ->- `CInt' id #}--type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()--foreign import ccall "wrapper" - marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc)--{#pointer *HsQMLClassHandle as ^ foreign newtype #}--foreign import ccall "hsqml.h &hsqml_finalise_class_handle"- hsqmlFinaliseClassHandlePtr :: FunPtr (Ptr (HsQMLClassHandle) -> IO ())--newClassHandle :: Ptr HsQMLClassHandle -> IO (Maybe HsQMLClassHandle)-newClassHandle p =- if nullPtr == p- then return Nothing- else do- fp <- newForeignPtr hsqmlFinaliseClassHandlePtr p- return $ Just $ HsQMLClassHandle fp--{#fun unsafe hsqml_create_class as ^- {id `Ptr CUInt',- id `Ptr CChar',- id `Ptr (FunPtr UniformFunc)',- id `Ptr (FunPtr UniformFunc)'} ->- `Maybe HsQMLClassHandle' newClassHandle* #}--withMaybeHsQMLClassHandle ::- Maybe HsQMLClassHandle -> (Ptr HsQMLClassHandle -> IO b) -> IO b-withMaybeHsQMLClassHandle (Just (HsQMLClassHandle fp)) = withForeignPtr fp-withMaybeHsQMLClassHandle Nothing = \f -> f nullPtr--withMaybeHsQMLObjectHandle ::- Maybe HsQMLObjectHandle -> (Ptr HsQMLObjectHandle -> IO b) -> IO b-withMaybeHsQMLObjectHandle (Just (HsQMLObjectHandle fp)) = withForeignPtr fp-withMaybeHsQMLObjectHandle Nothing = \f -> f nullPtr--{#pointer *HsQMLObjectHandle as ^ foreign newtype #}--foreign import ccall "hsqml.h &hsqml_finalise_object_handle"- hsqmlFinaliseObjectHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ())--newObjectHandle :: Ptr HsQMLObjectHandle -> IO HsQMLObjectHandle-newObjectHandle p = do- fp <- newForeignPtr hsqmlFinaliseObjectHandlePtr p- return $ HsQMLObjectHandle fp--isNullObjectHandle :: HsQMLObjectHandle -> Bool-isNullObjectHandle (HsQMLObjectHandle fp) =- nullPtr == unsafeForeignPtrToPtr fp---- | Represents an instance of the QML class which wraps the type @tt@.-data ObjRef tt = ObjRef {- objHndl :: HsQMLObjectHandle-}--objToPtr :: a -> (Ptr () -> IO b) -> IO b-objToPtr obj f = do- sPtr <- newStablePtr obj- res <- f $ castStablePtrToPtr sPtr- return res--{#fun unsafe hsqml_create_object as ^- {objToPtr* `a',- withHsQMLClassHandle* `HsQMLClassHandle'} ->- `HsQMLObjectHandle' newObjectHandle* #}--ptrToObj :: Ptr () -> IO a-ptrToObj =- deRefStablePtr . castPtrToStablePtr--{#fun unsafe hsqml_object_get_haskell as ^- {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `a' ptrToObj* #}--{#fun unsafe hsqml_object_get_pointer as ^- {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `Ptr ()' id #}--{#fun unsafe hsqml_get_object_handle as ^- {id `Ptr ()',- withMaybeHsQMLClassHandle* `Maybe HsQMLClassHandle'} ->- `HsQMLObjectHandle' newObjectHandle* #}--ofDynamicMetaObject :: CUInt-ofDynamicMetaObject = 0x01--mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask,- mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor,- mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable- :: CUInt-mfAccessPrivate = 0x00-mfAccessProtected = 0x01-mfAccessPublic = 0x02-mfAccessMask = 0x03-mfMethodMethod = 0x00-mfMethodSignal = 0x04-mfMethodSlot = 0x08-mfMethodConstructor = 0x0c-mfMethodTypeMask = 0x0c-mfMethodCompatibility = 0x10-mfMethodCloned = 0x20-mfMethodScriptable = 0x40--pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet,- pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable,- pfResolveScriptable, pfStored, pfResolveStored, pfEditable,- pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt-pfInvalid = 0x00000000-pfReadable = 0x00000001-pfWritable = 0x00000002-pfResettable = 0x00000004-pfEnumOrFlag = 0x00000008-pfStdCppSet = 0x00000100-pfConstant = 0x00000400-pfFinal = 0x00000800-pfDesignable = 0x00001000-pfResolveDesignable = 0x00002000-pfScriptable = 0x00004000-pfResolveScriptable = 0x00008000-pfStored = 0x00010000-pfResolveStored = 0x00020000-pfEditable = 0x00040000-pfResolveEditable = 0x00080000-pfUser = 0x00100000-pfResolveUser = 0x00200000-pfNotify = 0x00400000
+ src/Graphics/QML/Internal/Objects.hs view
@@ -0,0 +1,122 @@+{-# LANGUAGE+ ScopedTypeVariables,+ TypeFamilies,+ FlexibleContexts,+ FlexibleInstances,+ Rank2Types+ #-}++module Graphics.QML.Internal.Objects where++import Graphics.QML.Internal.BindObj+import Graphics.QML.Internal.Marshal++import Data.Typeable+import Data.Bits+import Data.Char++data MemberKind+ = MethodMember+ | PropertyMember+ | SignalMember+ deriving (Bounded, Enum, Eq)++-- | Represents a named member of the QML class which wraps type @tt@.+data Member tt = Member {+ memberKind :: MemberKind,+ memberName :: String,+ memberType :: TypeName,+ memberParams :: [TypeName],+ memberFun :: UniformFunc,+ memberFunAux :: Maybe UniformFunc,+ memberKey :: Maybe TypeRep+}++-- | Represents the API of the QML class which wraps the type @tt@.+newtype ClassDef tt = ClassDef {+ classMembers :: [Member tt]+}++-- | The class 'Object' allows Haskell types to expose an object-oriented+-- interface to QML. +class (Typeable tt) => Object tt where+ classDef :: ClassDef tt++type MObjToHsFunc t = HsQMLObjectHandle -> IO t+type MHsToObjFunc t = t -> IO HsQMLObjectHandle++-- | Type function yielding the object type specified by a given 'MarshalMode'.+type family ModeObj m++-- | Type function yielding the object type speficied by a given marshallable+-- type @tt@.+type ThisObj tt = ModeObj (MarshalMode tt)++-- | Class for 'MarshalMode's which support marshalling QML-to-Haskell+-- in contexts specific to objects.+class (MarshalBase m) => MarshalFromObj m where+ mObjToHs_ :: forall t. Marshaller t m -> MObjToHsFunc t++mObjToHs ::+ forall t. (Marshal t, MarshalFromObj (MarshalMode t)) => MObjToHsFunc t+mObjToHs = mObjToHs_ (marshaller :: Marshaller t (MarshalMode t))++-- | Class for 'MarshalMode's which support marshalling Haskell-to-QML+-- in contexts specific to objects.+class (MarshalBase m) => MarshalToObj m where+ mHsToObj_ :: forall t. Marshaller t m -> MHsToObjFunc t++mHsToObj ::+ forall t. (Marshal t, MarshalToObj (MarshalMode t)) => MHsToObjFunc t+mHsToObj = mHsToObj_ (marshaller :: Marshaller t (MarshalMode t))++-- | 'MarshalMode' for object types.+data ValObjBidi a+type instance ModeObj (ValObjBidi a) = a++data instance Marshaller t (ValObjBidi a) = MValObjBidi {+ mValObjBidi_typeName :: !(MTypeNameFunc t),+ mValObjBidi_valToHs :: !(MValToHsFunc t),+ mValObjBidi_hsToVal :: !(MHsToValFunc t),+ mValObjBidi_hsToAlloc :: !(MHsToAllocFunc t),+ mValObjBidi_objToHs :: !(MObjToHsFunc t),+ mValObjBidi_hsToObj :: !(MHsToObjFunc t)}++instance MarshalBase (ValObjBidi a) where+ mTypeName_ = mValObjBidi_typeName++instance MarshalToHs (ValObjBidi a) where+ mValToHs_ = mValObjBidi_valToHs++instance MarshalToValRaw (ValObjBidi a) where+ mHsToVal_ = mValObjBidi_hsToVal+ mHsToAlloc_ = mValObjBidi_hsToAlloc++instance MarshalToVal (ValObjBidi a) where++instance MarshalToObj (ValObjBidi a) where+ mHsToObj_ = mValObjBidi_hsToObj++instance MarshalFromObj (ValObjBidi a) where+ mObjToHs_ = mValObjBidi_objToHs++-- | 'MarshalMode' for object types, operating only in the QML-to-Haskell+-- direction.+data ValObjToOnly a++type instance ModeObj (ValObjToOnly a) = a++data instance Marshaller t (ValObjToOnly a) = MValObjToOnly {+ mValObjToOnly_typeName :: !(MTypeNameFunc t),+ mValObjToOnly_valToHs :: !(MValToHsFunc t),+ mValObjToOnly_objToHs :: !(MObjToHsFunc t)}++instance MarshalBase (ValObjToOnly a) where+ mTypeName_ = mValObjToOnly_typeName++instance MarshalToHs (ValObjToOnly a) where+ mValToHs_ = mValObjToOnly_valToHs++instance MarshalFromObj (ValObjToOnly a) where+ mObjToHs_ = mValObjToOnly_objToHs+
− src/Graphics/QML/Internal/PrimValues.chs
@@ -1,82 +0,0 @@-{-# LANGUAGE- ForeignFunctionInterface- #-}--module Graphics.QML.Internal.PrimValues where--import Foreign.C.Types-import Foreign.C.String-import Foreign.Ptr-import Foreign.ForeignPtr-import Foreign.Storable-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array-import System.IO.Unsafe--#include "hsqml.h"--cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral------- String-----{#pointer *HsQMLStringHandle as ^ newtype #}--{#fun unsafe hsqml_get_string_size as ^- {} ->- `Int' fromIntegral #}--hsqmlStringSize :: Int-hsqmlStringSize = unsafePerformIO $ hsqmlGetStringSize--{#fun unsafe hsqml_init_string as ^- {id `HsQMLStringHandle'} ->- `()' #}--{#fun unsafe hsqml_deinit_string as ^- {id `HsQMLStringHandle'} ->- `()' #}--{#fun unsafe hsqml_marshal_string as ^- {`Int',- id `HsQMLStringHandle'} ->- `Ptr CUShort' id #}--{#fun unsafe hsqml_unmarshal_string as ^- {id `HsQMLStringHandle',- id `Ptr (Ptr CUShort)'} ->- `Int' #}------- URL-----{#pointer *HsQMLUrlHandle as ^ newtype #}--{#fun unsafe hsqml_get_url_size as ^- {} ->- `Int' fromIntegral #}--hsqmlUrlSize :: Int-hsqmlUrlSize = unsafePerformIO $ hsqmlGetUrlSize--{#fun unsafe hsqml_init_url as ^- {id `HsQMLUrlHandle'} ->- `()' #}--{#fun unsafe hsqml_deinit_url as ^- {id `HsQMLUrlHandle'} ->- `()' #}--{#fun unsafe hsqml_marshal_url as ^- {id `Ptr CChar',- `Int',- id `HsQMLUrlHandle'} ->- `()' #}--{#fun unsafe hsqml_unmarshal_url as ^- {id `HsQMLUrlHandle',- id `Ptr (Ptr CChar)'} ->- `Int' #}
src/Graphics/QML/Marshal.hs view
@@ -1,22 +1,35 @@ {-# LANGUAGE ScopedTypeVariables,+ TypeFamilies, TypeSynonymInstances, FlexibleInstances #-} -- | Type classs and instances for marshalling values between Haskell and QML. module Graphics.QML.Marshal (- MarshalIn (- mIn),- InMarshaller,- MarshalOut+ Marshal (+ type MarshalMode,+ marshaller),+ MarshalToHs,+ MarshalToValRaw,+ MarshalToVal,+ MarshalFromObj,+ MarshalToObj,+ ValBidi,+ ValFnRetVoid,+ ValObjBidi,+ ValObjToOnly,+ ThisObj,+ Marshaller ) where +import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.PrimValues+import Graphics.QML.Internal.Objects import Data.Maybe import Data.Tagged+import Data.Int import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Foreign as T@@ -32,88 +45,82 @@ isUnescapedInURI) ----- Int/int built-in type+-- Int32/int built-in type -- -instance MarshalOut Int where- mOutFunc ptr int =- poke (castPtr ptr :: Ptr CInt) (fromIntegral int)- mOutAlloc num f =- alloca $ \(ptr :: Ptr CInt) ->- mOutFunc (castPtr ptr) num >> f (castPtr ptr)--instance MarshalIn Int where- mIn = InMarshaller {- mInFuncFld = \ptr ->+instance Marshal Int32 where+ type MarshalMode Int32 = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "int",+ mValBidi_valToHs = \ptr -> errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,- mIOTypeFld = Tagged $ TypeName "int"- }+ mValBidi_hsToVal = \int ptr ->+ poke (castPtr ptr :: Ptr CInt) (fromIntegral int),+ mValBidi_hsToAlloc = \int f ->+ alloca $ \(ptr :: Ptr CInt) ->+ mHsToVal int (castPtr ptr) >> f (castPtr ptr)} +instance Marshal Int where+ type MarshalMode Int = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "int",+ mValBidi_valToHs = fmap (fromIntegral :: Int32 -> Int) . mValToHs,+ mValBidi_hsToVal = \int ptr -> mHsToVal (fromIntegral int :: Int32) ptr,+ mValBidi_hsToAlloc = \int f -> mHsToAlloc (fromIntegral int :: Int32) f}+ -- -- Double/double built-in type -- -instance MarshalOut Double where- mOutFunc ptr num =- poke (castPtr ptr :: Ptr CDouble) (realToFrac num)- mOutAlloc num f =- alloca $ \(ptr :: Ptr CDouble) ->- mOutFunc (castPtr ptr) num >> f (castPtr ptr)--instance MarshalIn Double where- mIn = InMarshaller {- mInFuncFld = \ptr ->+instance Marshal Double where+ type MarshalMode Double = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "double",+ mValBidi_valToHs = \ptr -> errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,- mIOTypeFld = Tagged $ TypeName "double"- }+ mValBidi_hsToVal = \num ptr ->+ poke (castPtr ptr :: Ptr CDouble) (realToFrac num),+ mValBidi_hsToAlloc = \num f ->+ alloca $ \(ptr :: Ptr CDouble) ->+ mHsToVal num (castPtr ptr) >> f (castPtr ptr)} -- -- Text/QString built-in type -- -instance MarshalOut Text where- mOutFunc ptr txt = do- array <- hsqmlMarshalString- (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)- T.unsafeCopyToPtr txt (castPtr array)- mOutAlloc txt f =- allocaBytes hsqmlStringSize $ \ptr -> do- hsqmlInitString $ HsQMLStringHandle ptr- mOutFunc (castPtr ptr) txt- ret <- f (castPtr ptr)- hsqmlDeinitString $ HsQMLStringHandle ptr- return ret--instance MarshalIn Text where- mIn = InMarshaller {- mInFuncFld = \ptr -> errIO $ do+instance Marshal Text where+ type MarshalMode Text = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "QString",+ mValBidi_valToHs = \ptr -> errIO $ do pair <- alloca (\bufPtr -> do len <- hsqmlUnmarshalString (HsQMLStringHandle $ castPtr ptr) bufPtr buf <- peek bufPtr return (castPtr buf, fromIntegral len)) uncurry T.fromPtr pair,- mIOTypeFld = Tagged $ TypeName "QString"- }+ mValBidi_hsToVal = \txt ptr -> do+ array <- hsqmlMarshalString+ (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)+ T.unsafeCopyToPtr txt (castPtr array),+ mValBidi_hsToAlloc = \txt f ->+ allocaBytes hsqmlStringSize $ \ptr -> do+ hsqmlInitString $ HsQMLStringHandle ptr+ mHsToVal txt (castPtr ptr)+ ret <- f (castPtr ptr)+ hsqmlDeinitString $ HsQMLStringHandle ptr+ return ret} -- -- String/QString built-in type -- -instance MarshalOut String where- mOutFunc ptr str = mOutFunc ptr $ T.pack str- mOutAlloc txt f =- allocaBytes hsqmlStringSize $ \ptr -> do- hsqmlInitString $ HsQMLStringHandle ptr- mOutFunc (castPtr ptr) txt- ret <- f (castPtr ptr)- hsqmlDeinitString $ HsQMLStringHandle ptr- return ret--instance MarshalIn String where- mIn = InMarshaller {- mInFuncFld = fmap T.unpack . mInFuncFld mIn,- mIOTypeFld = Tagged $ TypeName "QString"- }+instance Marshal String where+ type MarshalMode String = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "QString",+ mValBidi_valToHs = fmap T.unpack . mValToHs,+ mValBidi_hsToVal = \txt ptr -> mHsToVal (T.pack txt) ptr,+ mValBidi_hsToAlloc = \txt f -> mHsToAlloc (T.pack txt) f} -- -- URI/QUrl built-in type@@ -126,23 +133,11 @@ Just $ URIAuth (f user) (f name) (f port) mapAuth Nothing = Nothing -instance MarshalOut URI where- mOutFunc ptr uri =- let str = uriToString id (mapURIStrings- (escapeURIString isUnescapedInURI) uri) ""- in withCStringLen str (\(buf, bufLen) ->- hsqmlMarshalUrl buf bufLen (HsQMLUrlHandle $ castPtr ptr))- mOutAlloc uri f =- allocaBytes hsqmlUrlSize $ \ptr -> do- hsqmlInitUrl $ HsQMLUrlHandle ptr- mOutFunc (castPtr ptr) uri- ret <- f (castPtr ptr)- hsqmlDeinitUrl $ HsQMLUrlHandle ptr- return ret--instance MarshalIn URI where- mIn = InMarshaller {- mInFuncFld = \ptr -> errIO $ do+instance Marshal URI where+ type MarshalMode URI = ValBidi+ marshaller = MValBidi {+ mValBidi_typeName = Tagged $ TypeName "QUrl",+ mValBidi_valToHs = \ptr -> errIO $ do pair <- alloca (\bufPtr -> do len <- hsqmlUnmarshalUrl (HsQMLUrlHandle $ castPtr ptr) bufPtr buf <- peek bufPtr@@ -151,5 +146,15 @@ free $ fst pair return $ mapURIStrings unEscapeString $ fromMaybe nullURI $ parseURIReference str,- mIOTypeFld = Tagged $ TypeName "QUrl"- }+ mValBidi_hsToVal = \uri ptr ->+ let str = uriToString id (mapURIStrings+ (escapeURIString isUnescapedInURI) uri) ""+ in withCStringLen str (\(buf, bufLen) ->+ hsqmlMarshalUrl buf bufLen (HsQMLUrlHandle $ castPtr ptr)),+ mValBidi_hsToAlloc = \uri f ->+ allocaBytes hsqmlUrlSize $ \ptr -> do+ hsqmlInitUrl $ HsQMLUrlHandle ptr+ mHsToVal uri (castPtr ptr)+ ret <- f (castPtr ptr)+ hsqmlDeinitUrl $ HsQMLUrlHandle ptr+ return ret}
src/Graphics/QML/Objects.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies,- FlexibleContexts+ FlexibleContexts,+ FlexibleInstances #-} -- | Facilities for defining new object types which can be marshalled between@@ -22,33 +23,46 @@ defPropertyRO, defPropertyRW, + -- * Signals+ defSignal,+ fireSignal,+ SignalKey (+ type SignalParams),+ SignalSuffix,+ -- * Object References ObjRef, newObject, fromObjRef, - -- * Marshalling Type-classes- objectInMarshaller,- MarshalThis (- type ThisObj,- mThis),- objectThisMarshaller+ -- * Dynamic Object References+ AnyObjRef,+ anyObjRef,+ fromAnyObjRef,++ -- * Customer Marshallers+ objSimpleMarshaller,+ objBidiMarshaller ) where +import Graphics.QML.Internal.BindCore+import Graphics.QML.Internal.BindObj+import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.Objects-import Graphics.QML.Internal.Engine +import Control.Concurrent.MVar import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.Trans.State+import Control.Exception import Data.Bits-import Data.Char import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Tagged import Data.Typeable+import Data.IORef import Foreign.C.Types import Foreign.C.String import Foreign.Ptr@@ -59,392 +73,558 @@ import Numeric ----- ObjRef+-- Counted Reverse List -- --- | The class 'MarshalThis' allows objects to be marshalled back into--- Haskell as the \"this\" value for callbacks.-class (Object (ThisObj tt)) => MarshalThis tt where- type ThisObj tt- mThis :: ThisMarshaller tt---- | Encapsulates the functionality to needed to implement an instance of--- 'MarshalThis' so that such instances can be defined without access to--- implementation details.-data ThisMarshaller tt = ThisMarshaller {- mThisFuncFld :: Ptr () -> IO tt+data CRList a = CRList {+ crlLen :: !Int,+ crlList :: [a] } -mThisFunc :: (MarshalThis tt) => Ptr () -> IO tt-mThisFunc = mThisFuncFld mThis--instance (Object tt) => MarshalOut (ObjRef tt) where- mOutFunc ptr obj = do- objPtr <- hsqmlObjectGetPointer $ objHndl obj- poke (castPtr ptr) objPtr- mOutAlloc obj f =- alloca $ \(ptr :: Ptr (Ptr ())) ->- mOutFunc (castPtr ptr) obj >> f (castPtr ptr)--instance (Object tt) => MarshalIn (ObjRef tt) where- mIn = InMarshaller {- mInFuncFld = \ptr -> MaybeT $ do- objPtr <- peek (castPtr ptr)- hndl <- hsqmlGetObjectHandle objPtr $- Just $ classHndl (classDefCAF :: ClassDef tt)- return $ if isNullObjectHandle hndl- then Nothing else Just $ ObjRef hndl,- mIOTypeFld = Tagged $ TypeName "QObject*"- }+crlEmpty :: CRList a+crlEmpty = CRList 0 [] -instance (Object tt) => MarshalThis (ObjRef tt) where- type ThisObj (ObjRef tt) = tt- mThis = ThisMarshaller {- mThisFuncFld = \ptr -> do- hndl <- hsqmlGetObjectHandle ptr Nothing- return $ ObjRef hndl- }+crlAppend1 :: CRList a -> a -> CRList a+crlAppend1 (CRList n xs) x = CRList (n+1) (x:xs) -retagType :: Tagged (ObjRef tt) TypeName -> Tagged tt TypeName-retagType = retag+crlAppend :: CRList a -> [a] -> CRList a+crlAppend (CRList n xs) ys = CRList n' xs'+ where (xs', n') = rev ys xs n+ rev [] vs n = (vs, n)+ rev (u:us) vs n = rev us (u:vs) (n+1) --- | Provides an 'InMarshaller' which allows you to define instances of--- 'MarshalIn' for custom object types. For example: ----- @--- instance MarshalIn MyObjectType where--- mIn = objectInMarshaller--- @+-- ObjRef ----- This instance would allow @MyObjectType@ to be used as a parameter type--- in callbacks. An instance is provided for @'ObjRef' MyObjectType@ by--- default.-objectInMarshaller :: (Object tt) => InMarshaller tt-objectInMarshaller =- InMarshaller {- mInFuncFld = fmap fromObjRef . mInFunc,- mIOTypeFld = retagType mIOType- } --- | Provides an 'ThisMarshaller' which allows you to define instances of--- 'MarshalThis' for custom object types. For example:------ @--- instance MarshalThis MyObjectType where--- type (ThisObj MyObjectType) = MyObjectType--- mIn = objectInMarshaller--- @------ This instance would allow @MyObjectType@ to be used as the \"this\" type--- for callbacks. An instance is provided for @'ObjRef' MyObjectType@ by--- default.-objectThisMarshaller :: (Object tt, (ThisObj tt) ~ tt) => ThisMarshaller tt-objectThisMarshaller =- ThisMarshaller {- mThisFuncFld = fmap fromObjRef . mThisFunc- }+-- | Represents an instance of the QML class which wraps the type @tt@.+data ObjRef tt = ObjRef {+ objHndl :: HsQMLObjectHandle+} +instance (Object tt) => Marshal (ObjRef tt) where+ type MarshalMode (ObjRef tt) = ValObjBidi tt+ marshaller = MValObjBidi {+ mValObjBidi_typeName = Tagged $ TypeName "QObject*",+ mValObjBidi_valToHs = \ptr -> do+ any <- mValToHs ptr+ MaybeT $ return $ fromAnyObjRef any,+ mValObjBidi_hsToVal = \obj ptr ->+ mHsToVal (AnyObjRef $ objHndl obj) ptr,+ mValObjBidi_hsToAlloc = \obj f ->+ mHsToAlloc (AnyObjRef $ objHndl obj) f,+ mValObjBidi_objToHs = \hndl ->+ return $ ObjRef hndl,+ mValObjBidi_hsToObj = \obj ->+ return $ objHndl obj}+ -- | Creates an instance of a QML class given a value of the underlying Haskell -- type @tt@. newObject :: forall tt. (Object tt) => tt -> IO (ObjRef tt) newObject obj = do- hndl <- hsqmlCreateObject obj $ classHndl (classDefCAF :: ClassDef tt)- return $ ObjRef hndl+ cRec <- getClassRec (classDef :: ClassDef tt)+ oHndl <- hsqmlCreateObject obj $ crecHndl cRec+ return $ ObjRef oHndl -- | Returns the associated value of the underlying Haskell type @tt@ from an -- instance of the QML class which wraps it. fromObjRef :: ObjRef tt -> tt fromObjRef =- unsafePerformIO . hsqmlObjectGetHaskell . objHndl+ unsafePerformIO . fromObjRefIO +fromObjRefIO :: ObjRef tt -> IO tt+fromObjRefIO =+ hsqmlObjectGetHaskell . objHndl ++-- | Represents an instance of a QML class which wraps an arbitrary Haskell+-- type. Unlike 'ObjRef', an 'AnyObjRef' only carries the type of its Haskell+-- value dynamically and does not encode it into the static type.+data AnyObjRef = AnyObjRef {+ anyObjHndl :: HsQMLObjectHandle+}++instance Marshal AnyObjRef where+ type MarshalMode AnyObjRef = ValObjBidi ()+ marshaller = MValObjBidi {+ mValObjBidi_typeName = Tagged $ TypeName "QObject*",+ mValObjBidi_valToHs = \ptr -> MaybeT $ do+ objPtr <- peek (castPtr ptr)+ hndl <- hsqmlGetObjectHandle objPtr+ return $ if isNullObjectHandle hndl+ then Nothing else Just $ AnyObjRef hndl,+ mValObjBidi_hsToVal = \obj ptr -> do+ objPtr <- hsqmlObjectGetPointer $ anyObjHndl obj+ poke (castPtr ptr) objPtr,+ mValObjBidi_hsToAlloc = \obj f ->+ alloca $ \(ptr :: Ptr (Ptr ())) ->+ flip mHsToVal (castPtr ptr) obj >> f (castPtr ptr),+ mValObjBidi_objToHs = \hndl ->+ return $ AnyObjRef hndl,+ mValObjBidi_hsToObj = \obj ->+ return $ anyObjHndl obj}++-- | Upcasts an 'ObjRef' into an 'AnyObjRef'.+anyObjRef :: ObjRef tt -> AnyObjRef+anyObjRef (ObjRef hndl) = AnyObjRef hndl++-- | Attempts to downcast an 'AnyObjRef' into an 'ObjRef' with the specific+-- underlying Haskell type @tt@.+fromAnyObjRef :: (Object tt) => AnyObjRef -> Maybe (ObjRef tt)+fromAnyObjRef = unsafePerformIO . fromAnyObjRefIO++fromAnyObjRefIO :: forall tt. (Object tt) => AnyObjRef -> IO (Maybe (ObjRef tt))+fromAnyObjRefIO (AnyObjRef hndl) = do+ let srcRep = typeOf (undefined :: tt)+ dstRep <- hsqmlObjectGetHsTyperep hndl+ if srcRep == dstRep+ then return $ Just $ ObjRef hndl+ else return Nothing++-- | Provides a QML-to-Haskell 'Marshaller' which allows you to define+-- instances of 'Marshal' for custom 'Object' types. This allows a custom types+-- to be passed into Haskell code as method parameters without having to+-- manually deal with 'ObjRef's. ----- Object+-- For example, an instance for 'MyObjectType' would be defined as follows: ------ | The class 'Object' allows Haskell types to expose an object-oriented--- interface to QML. -class (Typeable tt) => Object tt where- classDef :: ClassDef tt+-- @+-- instance Marshal MyObjectType where+-- type MarshalMode MyObjectType = ValObjToOnly MyObjectType+-- marshaller = objSimpleMarshaller+-- @+objSimpleMarshaller ::+ forall obj. (Object obj) => Marshaller obj (ValObjToOnly obj)+objSimpleMarshaller = MValObjToOnly {+ mValObjToOnly_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),+ mValObjToOnly_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,+ mValObjToOnly_objToHs = hsqmlObjectGetHaskell} --- | Uninlinable version of classDef to try and ensure that class definitions--- get stored as constant applicable forms.-{-# NOINLINE classDefCAF #-}-classDefCAF :: (Object tt) => ClassDef tt-classDefCAF = classDef+-- | Provides a bidirectional QML-to-Haskell and Haskell-to-QML 'Marshaller'+-- which allows you to define instances of 'Marshal' for custom object types.+-- This allows a custom type to be passed in and out of Haskell code via+-- methods, properties, and signals, without having to manually deal with+-- 'ObjRef's. Unlike the simple marshaller, this one must be given a function+-- which specifies how to obtain an 'ObjRef' given a Haskell value.+--+-- For example, an instance for 'MyObjectType' which simply creates a new+-- object whenever one is required would be defined as follows:+--+-- @+-- instance Marshal MyObjectType where+-- type MarshalMode MyObjectType = ValObjBidi MyObjectType+-- marshaller = objBidiMarshaller newObject+-- @+objBidiMarshaller ::+ forall obj. (Object obj) =>+ (obj -> IO (ObjRef obj)) -> Marshaller obj (ValObjBidi obj) +objBidiMarshaller newFn = MValObjBidi {+ mValObjBidi_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),+ mValObjBidi_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,+ mValObjBidi_hsToVal = \obj ptr -> flip mHsToVal ptr =<< newFn obj,+ mValObjBidi_hsToAlloc = \obj f -> flip mHsToAlloc f =<< newFn obj,+ mValObjBidi_objToHs = hsqmlObjectGetHaskell,+ mValObjBidi_hsToObj = fmap objHndl . newFn} -- -- ClassDef -- --- | Represents the API of the QML class which wraps the type @tt@.-data ClassDef tt = ClassDef {- classType :: TypeName,- classHndl :: HsQMLClassHandle-}- -- | Generates a 'ClassDef' from a list of 'Member's. defClass :: forall tt. (Object tt) => [Member tt] -> ClassDef tt-defClass ms = unsafePerformIO $ do- let typ = typeOf (undefined :: tt)- con = typeRepTyCon typ- name = showString (tyConModule con) $ showChar '.' $ tyConName con- id <- hsqmlGetNextClassId- createClass (showString name $ showChar '_' $ showInt id "") ms+defClass = ClassDef -createClass :: forall tt. (Object tt) =>- String -> [Member tt] -> IO (ClassDef tt)-createClass name ms = do- let methods = methodMembers ms- properties = propertyMembers ms- (MOCOutput metaData metaStrData) = compileClass name methods properties- metaDataPtr <- newArray metaData- metaStrDataPtr <- newArray metaStrData- methodsPtr <- mapM (marshalFunc . methodFunc) methods >>= newArray- pReads <- mapM (marshalFunc . propertyReadFunc) properties- pWrites <- mapM (fromMaybe (return nullFunPtr) . fmap marshalFunc .- propertyWriteFunc) properties- propertiesPtr <- newArray $ interleave pReads pWrites+data MemoStore k v = MemoStore (MVar (Map k v)) (IORef (Map k v))++newMemoStore :: IO (MemoStore k v)+newMemoStore = do+ let m = Map.empty+ mr <- newMVar m+ ir <- newIORef m+ return $ MemoStore mr ir++getFromMemoStore :: (Ord k) => MemoStore k v -> k -> IO v -> IO (Bool, v)+getFromMemoStore (MemoStore mr ir) key fn = do+ fstMap <- readIORef ir+ case Map.lookup key fstMap of+ Just val -> return (False, val)+ Nothing -> modifyMVar mr $ \sndMap -> do+ case Map.lookup key sndMap of+ Just val -> return (sndMap, (False, val))+ Nothing -> do+ val <- fn+ let newMap = Map.insert key val sndMap+ writeIORef ir newMap+ return (newMap, (True, val))++data ClassRec = ClassRec {+ crecHndl :: HsQMLClassHandle,+ crecSigs :: Map TypeRep Int+}++{-# NOINLINE classRecDb #-}+classRecDb :: MemoStore TypeRep ClassRec+classRecDb = unsafePerformIO $ newMemoStore++getClassRec :: forall tt. (Object tt) => ClassDef tt -> IO ClassRec+getClassRec cdef = do+ let typ = typeOf (undefined :: tt)+ (_, val) <- getFromMemoStore classRecDb typ (createClass typ cdef)+ return val++createClass :: forall tt. (Object tt) => TypeRep -> ClassDef tt -> IO ClassRec+createClass typRep cdef = do hsqmlInit- hndl <- hsqmlCreateClass metaDataPtr metaStrDataPtr methodsPtr propertiesPtr- return $ case hndl of - Just hndl' -> ClassDef (TypeName name) hndl'- Nothing -> error ("Failed to create QML class '"++name++"'.")+ classId <- hsqmlGetNextClassId+ let constrs t = typeRepTyCon t : (concatMap constrs $ typeRepArgs t)+ name = foldr (\c s -> showString (tyConName c) .+ showChar '_' . s) id (constrs typRep) $ showInt classId ""+ ms = classMembers cdef+ moc = compileClass name ms+ sigs = filterMembers SignalMember ms+ sigMap = Map.fromList $ flip zip [0..] $ map (fromJust . memberKey) sigs+ maybeMarshalFunc = maybe (return nullFunPtr) marshalFunc+ metaDataPtr <- crlToNewArray return (mData moc)+ metaStrDataPtr <- crlToNewArray return (mStrData moc)+ methodsPtr <- crlToNewArray maybeMarshalFunc (mFuncMethods moc)+ propsPtr <- crlToNewArray maybeMarshalFunc (mFuncProperties moc)+ maybeHndl <- hsqmlCreateClass+ metaDataPtr metaStrDataPtr typRep methodsPtr propsPtr+ case maybeHndl of+ Just hndl -> return $ ClassRec hndl sigMap+ Nothing -> error ("Failed to create QML class '"++name++"'.") -interleave :: [a] -> [a] -> [a]-interleave [] ys = ys-interleave (x:xs) ys = x : ys `interleave` xs +crlToNewArray :: (Storable b) => (a -> IO b) -> CRList a -> IO (Ptr b)+crlToNewArray f (CRList len lst) = do+ ptr <- mallocArray len+ pokeRev ptr lst len+ return ptr+ where pokeRev _ [] _ = return ()+ pokeRev p (x:xs) n = do+ let n' = n-1+ x' <- f x+ pokeElemOff p n' x'+ pokeRev p xs n' -- -- Member -- --- | Represents a named member of the QML class which wraps type @tt@.-data Member tt- -- | Constructs a 'Member' from a 'Method'.- = MethodMember (Method tt)- -- | Constructs a 'Member' from a 'Property'.- | PropertyMember (Property tt)---- | Returns the methods in a list of members.-methodMembers :: [Member tt] -> [Method tt]-methodMembers = mapMaybe f- where f (MethodMember m) = Just m- f _ = Nothing---- | Returns the properties in a list of members.-propertyMembers :: [Member tt] -> [Property tt]-propertyMembers = mapMaybe f- where f (PropertyMember m) = Just m- f _ = Nothing+filterMembers :: MemberKind -> [Member tt] -> [Member tt]+filterMembers k ms =+ filter (\m -> k == memberKind m) ms -- -- Method -- --- | Represents a named method which can be invoked from QML on an object of--- type @tt@.-data Method tt = Method {- -- | Gets the name of a 'Method'.- methodName :: String,- -- | Gets the 'TypeName's which comprise the signature of a 'Method'.- -- The head of the list is the return type and the tail the arguments.- methodTypes :: [TypeName],- methodFunc :: UniformFunc+data MethodTypeInfo = MethodTypeInfo {+ methodParamTypes :: [TypeName],+ methodReturnType :: TypeName } -data CrudeMethodTypes = CrudeMethodTypes {- methodParamTypes :: [TypeName],- methodReturnType :: TypeName- }--crudeTypesToList :: CrudeMethodTypes -> [TypeName]-crudeTypesToList (CrudeMethodTypes p r) = r:p+newtype MSHelp a = MSHelp a -- | Supports marshalling Haskell functions with an arbitrary number of -- arguments. class MethodSuffix a where mkMethodFunc :: Int -> a -> Ptr (Ptr ()) -> ErrIO ()- mkMethodTypes :: Tagged a CrudeMethodTypes+ mkMethodTypes :: Tagged a MethodTypeInfo -instance (MarshalIn a, MethodSuffix b) => MethodSuffix (a -> b) where- mkMethodFunc n f pv = do+instance (Marshal a, MarshalToHs (MarshalMode a), MethodSuffix (MSHelp b)) =>+ MethodSuffix (MSHelp (a -> b)) where+ mkMethodFunc n (MSHelp f) pv = do ptr <- errIO $ peekElemOff pv n- val <- mInFunc ptr- mkMethodFunc (n+1) (f val) pv+ val <- mValToHs ptr+ mkMethodFunc (n+1) (MSHelp $ f val) pv return () mkMethodTypes =- let (CrudeMethodTypes p r) =- untag (mkMethodTypes :: Tagged b CrudeMethodTypes)- ty = untag (mIOType :: Tagged a TypeName)- in Tagged $ CrudeMethodTypes (ty:p) r+ let (MethodTypeInfo p r) =+ untag (mkMethodTypes :: Tagged (MSHelp b) MethodTypeInfo)+ typ = untag (mTypeName :: Tagged a TypeName)+ in Tagged $ MethodTypeInfo (typ:p) r -instance (MarshalOut a) => MethodSuffix (IO a) where- mkMethodFunc _ f pv = errIO $ do+instance (Marshal a, MarshalToValRaw (MarshalMode a)) =>+ MethodSuffix (MSHelp (IO a)) where+ mkMethodFunc _ (MSHelp f) pv = errIO $ do ptr <- peekElemOff pv 0 val <- f if nullPtr == ptr then return ()- else mOutFunc ptr val+ else mHsToVal val ptr mkMethodTypes =- let ty = untag (mIOType :: Tagged a TypeName)- in Tagged $ CrudeMethodTypes [] ty+ let typ = untag (mTypeName :: Tagged a TypeName)+ in Tagged $ MethodTypeInfo [] typ -mkUniformFunc :: forall tt ms. (MarshalThis tt, MethodSuffix ms) =>+mkUniformFunc :: forall tt ms.+ (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) => (tt -> ms) -> UniformFunc mkUniformFunc f = \pt pv -> do- this <- mThisFunc pt- runErrIO $ mkMethodFunc 1 (f this) pv+ hndl <- hsqmlGetObjectHandle pt+ this <- mObjToHs hndl+ runErrIO $ mkMethodFunc 1 (MSHelp $ f this) pv +newtype VoidIO = VoidIO {runVoidIO :: (IO ())}++instance MethodSuffix (MSHelp VoidIO) where+ mkMethodFunc _ (MSHelp f) pv = errIO $ runVoidIO f+ mkMethodTypes = Tagged $ MethodTypeInfo [] (TypeName "")++class IsVoidIO a+instance (IsVoidIO b) => IsVoidIO (a -> b)+instance IsVoidIO VoidIO++mkSpecialFunc :: forall tt ms.+ (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms),+ IsVoidIO ms) => (tt -> ms) -> UniformFunc+mkSpecialFunc f = \pt pv -> do+ hndl <- hsqmlGetObjectHandle pt+ this <- mObjToHs hndl+ runErrIO $ mkMethodFunc 0 (MSHelp $ f this) pv+ -- | Defines a named method using a function @f@ in the IO monad. -- -- The first argument to @f@ receives the \"this\" object and hence must match -- the type of the class on which the method is being defined. Subsequently, -- there may be zero or more parameter arguments followed by an optional return--- argument in the IO monad. These argument types must be members of the--- 'MarshalThis', 'MarshalIn', and 'MarshalOut' typeclasses respectively.--defMethod ::- forall tt ms. (MarshalThis tt, MethodSuffix ms) =>+-- argument in the IO monad.+defMethod :: forall tt ms.+ (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) => String -> (tt -> ms) -> Member (ThisObj tt)-defMethod name f = MethodMember $ Method name- (crudeTypesToList $ untag (mkMethodTypes :: Tagged ms CrudeMethodTypes))- (mkUniformFunc f)+defMethod name f =+ let crude = untag (mkMethodTypes :: Tagged (MSHelp ms) MethodTypeInfo)+ in Member MethodMember+ name+ (methodReturnType crude)+ (methodParamTypes crude)+ (mkUniformFunc f)+ Nothing+ Nothing -- -- Property -- --- | Represents a named property which can be accessed from QML on an object--- of type @tt@.-data Property tt = Property {- -- | Gets the name of a 'Property'.- propertyName :: String,- propertyType :: TypeName,- propertyReadFunc :: UniformFunc,- propertyWriteFunc :: Maybe UniformFunc-}- -- | Defines a named read-only property using an accessor function in the IO -- monad. defPropertyRO ::- forall tt tr. (MarshalThis tt, MarshalOut tr) =>+ forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),+ Marshal tr, MarshalToVal (MarshalMode tr)) => String -> (tt -> IO tr) -> Member (ThisObj tt)-defPropertyRO name g = PropertyMember $ Property name- (untag (mIOType :: Tagged tr TypeName))+defPropertyRO name g = Member PropertyMember+ name+ (untag (mTypeName :: Tagged tr TypeName))+ [] (mkUniformFunc g) Nothing+ Nothing -- | Defines a named read-write property using a pair of accessor and mutator -- functions in the IO monad. defPropertyRW ::- forall tt tr. (MarshalThis tt, MarshalOut tr) =>+ forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),+ Marshal tr, MarshalToHs (MarshalMode tr), MarshalToVal (MarshalMode tr)) => String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (ThisObj tt)-defPropertyRW name g s = PropertyMember $ Property name- (untag (mIOType :: Tagged tr TypeName))+defPropertyRW name g s = Member PropertyMember+ name+ (untag (mTypeName :: Tagged tr TypeName))+ [] (mkUniformFunc g)- (Just $ mkUniformFunc s)+ (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))+ Nothing --+-- Signal+--++data SignalTypeInfo = SignalTypeInfo {+ signalParamTypes :: [TypeName]+}++-- | Defines a named signal using a 'SignalKey'.+defSignal ::+ forall obj sk. (Object obj, SignalKey sk) => Tagged sk String -> Member obj+defSignal tn =+ let crude = untag (mkSignalTypes :: Tagged (SignalParams sk) SignalTypeInfo)+ in Member SignalMember+ (untag tn)+ (TypeName "")+ (signalParamTypes crude)+ (\_ _ -> return ())+ Nothing+ (Just $ typeOf (undefined :: sk))++-- | Fires a signal on an 'Object', specified using a 'SignalKey'.+fireSignal ::+ forall tt sk. (+ Marshal tt, MarshalToObj (MarshalMode tt),+ Object (ThisObj tt), SignalKey sk) =>+ Tagged sk tt -> SignalParams sk +fireSignal this =+ let start cnt = do+ crec <- getClassRec (classDef :: ClassDef (ThisObj tt))+ let keyRep = typeOf (undefined :: sk)+ slotMay = Map.lookup keyRep $ crecSigs crec+ case slotMay of+ Just slotIdx -> postJob $ do+ hndl <- mHsToObj $ untag this+ withActiveObject hndl $ cnt $ SignalData hndl slotIdx+ Nothing ->+ error ("Attempt to fire undefined signal on class '"+++ (typeName $ untag (mTypeName :: Tagged tt TypeName))++"'.")+ cont ps (SignalData hndl slotIdx) =+ withArray (nullPtr:ps) (\pptr ->+ hsqmlFireSignal hndl slotIdx pptr)+ in mkSignalArgs start cont++data SignalData = SignalData HsQMLObjectHandle Int++-- | Instances of the 'SignalKey' class identify distinct signals. The+-- associated 'SignalParams' type specifies the signal's signature.+class (SignalSuffix (SignalParams sk), Typeable sk) => SignalKey sk where+ type SignalParams sk++-- | Supports marshalling an arbitrary number of arguments into a QML signal.+class SignalSuffix ss where+ mkSignalArgs :: forall usr.+ ((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss+ mkSignalTypes :: Tagged ss SignalTypeInfo++instance (Marshal a, MarshalToVal (MarshalMode a), SignalSuffix b) =>+ SignalSuffix (a -> b) where+ mkSignalArgs start cont param =+ mkSignalArgs start (\ps usr ->+ mHsToAlloc param (\ptr ->+ cont (ptr:ps) usr))+ mkSignalTypes =+ let (SignalTypeInfo p) =+ untag (mkSignalTypes :: Tagged b SignalTypeInfo)+ typ = untag (mTypeName :: Tagged a TypeName)+ in Tagged $ SignalTypeInfo (typ:p)++instance SignalSuffix (IO ()) where+ mkSignalArgs start cont =+ start $ cont []+ mkSignalTypes =+ Tagged $ SignalTypeInfo []++-- -- Meta Object Compiler -- data MOCState = MOCState {- mData :: [CUInt],- mDataLen :: Int,+ mData :: CRList CUInt, mDataMethodsIdx :: Maybe Int, mDataPropsIdx :: Maybe Int,- mStrData :: [CChar],- mStrDataLen :: Int,- mStrDataMap :: Map String CUInt-} deriving Show+ mStrData :: CRList CChar,+ mStrDataMap :: Map String CUInt,+ mFuncMethods :: CRList (Maybe UniformFunc),+ mFuncProperties :: CRList (Maybe UniformFunc),+ mMethodCount :: Int,+ mSignalCount :: Int,+ mPropertyCount :: Int+} -data MOCOutput = MOCOutput [CUInt] [CChar]+-- | Generate MOC meta-data from a class name and member list.+compileClass :: String -> [Member tt] -> MOCState+compileClass name ms = + let enc = flip execState newMOCState $ do+ writeInt 5 -- Revision+ writeString name -- Class name+ writeInt 0 >> writeInt 0 -- Class info+ writeIntegral $+ mMethodCount enc ++ mSignalCount enc -- Methods+ writeIntegral $+ fromMaybe 0 $ mDataMethodsIdx enc -- Methods (data index)+ writeIntegral $ mPropertyCount enc -- Properties+ writeIntegral $+ fromMaybe 0 $ mDataPropsIdx enc -- Properties (data index)+ writeInt 0 >> writeInt 0 -- Enums+ writeInt 0 >> writeInt 0 -- Constructors+ writeInt 0 -- Flags+ writeIntegral $ mSignalCount enc -- Signals+ mapM_ writeMethod $ filterMembers SignalMember ms+ mapM_ writeMethod $ filterMembers MethodMember ms+ mapM_ writeProperty $ filterMembers PropertyMember ms+ writeInt 0+ in enc newMOCState :: MOCState-newMOCState = MOCState [] 0 Nothing Nothing [] 0 Map.empty+newMOCState =+ MOCState crlEmpty Nothing Nothing crlEmpty Map.empty crlEmpty crlEmpty 0 0 0 writeInt :: CUInt -> State MOCState () writeInt int = do state <- get- let md = mData state- mdLen = mDataLen state- put $ state {mData = int:md, mDataLen = mdLen+1}+ put $ state {mData = mData state `crlAppend1` int} return () +writeIntegral :: (Integral a) => a -> State MOCState ()+writeIntegral int =+ writeInt (fromIntegral int)+ writeString :: String -> State MOCState () writeString str = do state <- get let msd = mStrData state- msdLen = mStrDataLen state msdMap = mStrDataMap state case (Map.lookup str msdMap) of Just idx -> writeInt idx Nothing -> do- let idx = fromIntegral msdLen- msd' = 0 : (map castCharToCChar (reverse str) ++ msd)- msdLen' = msdLen + length str + 1- msdMap' = Map.insert str idx msdMap+ let idx = crlLen msd+ msd' = msd `crlAppend` (map castCharToCChar str) `crlAppend1` 0+ msdMap' = Map.insert str (fromIntegral idx) msdMap put $ state { mStrData = msd',- mStrDataLen = msdLen', mStrDataMap = msdMap'}- writeInt idx+ writeIntegral idx -writeMethod :: Method tt -> State MOCState ()+writeMethod :: Member tt -> State MOCState () writeMethod m = do- idx <- get >>= return . mDataLen+ idx <- get >>= return . crlLen . mData writeString $ methodSignature m writeString $ methodParameters m- writeString $ typeName $ head $ methodTypes m+ writeString $ typeName $ memberType m writeString ""- writeInt (mfAccessPublic .|. mfMethodScriptable)+ let (mc,sc,flags) = case memberKind m of+ SignalMember -> (0,1,mfMethodSignal)+ _ -> (1,0,0)+ writeInt (mfAccessPublic .|. mfMethodScriptable .|. flags) state <- get- put $ state {mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx)}+ put $ state {+ mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx),+ mMethodCount = mc + (mMethodCount state),+ mSignalCount = sc + (mSignalCount state),+ mFuncMethods = mFuncMethods state `crlAppend1` (Just $ memberFun m)} return () -writeProperty :: Property tt -> State MOCState ()+writeProperty :: Member tt -> State MOCState () writeProperty p = do- idx <- get >>= return . mDataLen- writeString $ propertyName p- writeString $ typeName $ propertyType p+ idx <- get >>= return . crlLen . mData+ writeString $ memberName p+ writeString $ typeName $ memberType p writeInt (pfReadable .|. pfScriptable .|.- if (isJust $ propertyWriteFunc p) then pfWritable else 0)+ if (isJust $ memberFunAux p) then pfWritable else 0) state <- get- put $ state {mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx)}+ put $ state {+ mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx),+ mPropertyCount = 1 + (mPropertyCount state),+ mFuncProperties = mFuncProperties state+ `crlAppend1` (Just $ memberFun p) `crlAppend1` memberFunAux p+ } return () -compileClass :: String -> [Method tt] -> [Property tt] -> MOCOutput-compileClass name ms ps = - let enc = flip execState newMOCState $ do- writeInt 5 -- Revision- writeString name -- Class name- writeInt 0 >> writeInt 0 -- Class info- writeInt $ fromIntegral $ length ms -- Methods- writeInt $ fromIntegral $- fromMaybe 0 $ mDataMethodsIdx enc -- Methods (data index)- writeInt $ fromIntegral $ length ps -- Properties- writeInt $ fromIntegral $- fromMaybe 0 $ mDataPropsIdx enc -- Properties (data index)- writeInt 0 >> writeInt 0 -- Enums- writeInt 0 >> writeInt 0 -- Constructors- writeInt 0 -- Flags- writeInt 0 -- Signals - mapM_ writeMethod ms- mapM_ writeProperty ps- writeInt 0- in MOCOutput (reverse $ mData enc) (reverse $ mStrData enc)- foldr0 :: (a -> a -> a) -> a -> [a] -> a foldr0 _ x [] = x foldr0 f _ xs = foldr1 f xs -methodSignature :: Method tt -> String+methodSignature :: Member tt -> String methodSignature method =- let paramTypes = tail $ methodTypes method- in (showString (methodName method) . showChar '(' .+ let paramTypes = memberParams method+ in (showString (memberName method) . showChar '(' . foldr0 (\l r -> l . showChar ',' . r) id (map (showString . typeName) paramTypes) . showChar ')') "" -methodParameters :: Method tt -> String+methodParameters :: Member tt -> String methodParameters method =- replicate (flip (-) 2 $ length $ methodTypes method) ','+ replicate (flip (-) 1 $ length $ memberParams method) ','
+ test/Graphics/QML/Test/Framework.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE ExistentialQuantification,+ ScopedTypeVariables,+ FlexibleInstances,+ DeriveDataTypeable,+ TypeFamilies #-}++module Graphics.QML.Test.Framework where++import Graphics.QML.Objects+import Graphics.QML.Marshal+import Graphics.QML.Test.MayGen+import Graphics.QML.Test.ScriptDSL (Prog)+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Gen+import Test.QuickCheck.Arbitrary+import Data.List (mapAccumR)+import Data.Maybe+import Data.Monoid+import Data.Proxy+import Data.Typeable+import Data.IORef+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI++data TestType = forall a. (TestAction a) => TestType (Proxy a)++instance Eq TestType where+ (==) (TestType a) (TestType b) = typeOf a == typeOf b++instance Show TestType where+ showsPrec d (TestType p) =+ showParen (d > 10) $ showString "TestType (Proxy :: " .+ shows (typeOf p) . showString ")"++newtype Serial = Serial Int deriving (Show, Eq)++badSerial :: Serial+badSerial = Serial (-1)++data TestEnv = TestEnv {+ envSerial :: Serial,+ envHs :: IntMap (TestType, Serial),+ envJs :: IntMap (TestType, Serial)+} deriving Show++newTestEnv :: TestType -> TestEnv+newTestEnv tt =+ TestEnv (Serial 1) IntMap.empty (IntMap.singleton 0 (tt, Serial 0))++testEnvStep :: TestEnv -> TestEnv+testEnvStep (TestEnv (Serial s) h j) =+ TestEnv (Serial $ s+1) h j++testEnvSerial :: (Serial -> TestEnv -> TestEnv) -> TestEnv -> TestEnv+testEnvSerial f env = f (envSerial env) env++testEnvSetJ :: Int -> TestType -> Serial -> TestEnv -> TestEnv+testEnvSetJ n tt js (TestEnv s h j) =+ TestEnv s h (IntMap.insert n (tt,js) j)++testEnvIsaJ :: Int -> TestType -> TestEnv -> Bool+testEnvIsaJ n tt env =+ case IntMap.lookup n $ envJs env of+ Just (tt', _) -> tt' == tt+ _ -> False++testEnvNextJ :: TestEnv -> Int+testEnvNextJ = (+1) . fst . IntMap.findMax . envJs++testEnvListJ :: TestType -> TestEnv -> [Int]+testEnvListJ tt env =+ map fst $ filter (\(_,(tt',_)) ->+ tt' == tt) $ IntMap.toList $ envJs env++data TestBox = forall a. (TestAction a) => TestBox Int a++instance Show TestBox where+ showsPrec d (TestBox n a) =+ showParen (d > 10) $ showString "TestBox " . shows n .+ showString " " . showsPrec 11 a++testBoxType :: TestBox -> TestType+testBoxType (TestBox _ a) =+ TestType $ mkProxy a+ where mkProxy = const Proxy :: a -> Proxy a++class (Typeable a, Show a) => TestAction a where+ legalActionIn :: a -> TestEnv -> Bool+ nextActionsFor :: TestEnv -> MayGen a+ updateEnvRaw :: a -> TestEnv -> TestEnv+ actionRemote :: a -> Int -> Prog+ mockObjDef :: [Member (MockObj a)]++legalAction :: TestEnv -> TestBox -> Bool+legalAction env tb@(TestBox n a) =+ (fmap fst $ IntMap.lookup n $ envJs env) == Just (testBoxType tb) &&+ legalActionIn a env++nextActions :: TestEnv -> Gen TestBox+nextActions env =+ oneof $ mapMaybe (uncurry f) $ IntMap.toList $ envJs env+ where f n ((TestType pxy), _) =+ (mayGen $ fmap (TestBox n . flip asProxyTypeOf pxy) $+ nextActionsFor env)++updateEnv :: TestBox -> TestEnv -> TestEnv+updateEnv (TestBox _ a) = updateEnvRaw a++showTestCode :: [TestBox] -> ShowS+showTestCode xs =+ let f (TestBox n a) = actionRemote a n+ in S.showProg $ mconcat $ map f xs ++ [S.end]++newtype TestBoxSrc a = TestBoxSrc { srcTestBoxes :: [TestBox]} deriving Show++genTestBoxes :: Int -> TestEnv -> Gen [TestBox]+genTestBoxes 0 _ = return []+genTestBoxes len env = do+ x <- nextActions env+ xs <- genTestBoxes (len-1) (updateEnv x env)+ return (x:xs)++partitions :: [a] -> [([a],[a])]+partitions xs =+ ([],xs) : case xs of+ [] -> []+ x:xs' -> map (\(hs,ts) -> (x:hs,ts)) $ partitions xs'++partitions1 :: [a] -> [([a],a,[a])]+partitions1 xs =+ mapMaybe f $ partitions xs+ where f (_,[]) = Nothing+ f (as,(b:cs)) = Just (as,b,cs)++pruneTestBoxes :: TestEnv -> [TestBox] -> [TestBox]+pruneTestBoxes env xs =+ catMaybes $ snd $ mapAccumR f env xs+ where f e x | legalAction e x = (updateEnv x e, Just x)+ | otherwise = (e, Nothing)++shrinkHelper :: TestEnv -> [TestBox] -> [TestBox] -> [TestBox]+shrinkHelper env xs ys =+ let env' = foldr updateEnv env xs+ ys' = pruneTestBoxes env' ys+ in xs ++ ys'++instance (TestAction a) => Arbitrary (TestBoxSrc a) where+ arbitrary =+ fmap TestBoxSrc $ sized $ \sz ->+ genTestBoxes sz $ newTestEnv $ TestType (Proxy :: Proxy a)+ shrink (TestBoxSrc xs) =+ map (\(a,_,b) -> TestBoxSrc $ shrinkHelper env a b) $ partitions1 xs+ where env = newTestEnv $ TestType (Proxy :: Proxy a)++mockFromSrc :: forall a. (TestAction a) => TestBoxSrc a -> IO (MockObj a)+mockFromSrc (TestBoxSrc ts) = do + statusRef <- newIORef $ TestStatus ts Nothing+ (newTestEnv $ TestType (Proxy :: Proxy a)) IntMap.empty+ return $ MockObj (Serial 0) statusRef++data TestFault+ = TOverAction+ | TUnderAction+ | TBadAction+ | TBadActionType+ | TBadActionCtor+ | TBadActionSlot+ | TBadActionData+ | TTimeout+ | TInvalid+ deriving Show++newtype Anything = Anything () deriving Show++data TestStatus = TestStatus {+ testList :: [TestBox],+ testFault :: Maybe TestFault,+ testEnv :: TestEnv,+ testObjs :: IntMap Anything+} deriving Show++testSerial :: TestStatus -> Serial+testSerial = envSerial . testEnv++data MockObj a = MockObj {+ mockSerial :: Serial,+ mockStatus :: IORef TestStatus+} deriving Typeable++mockGetStatus :: MockObj a -> IO TestStatus+mockGetStatus (MockObj _ statusRef) = readIORef statusRef++class MakeDefault a where+ makeDef :: IO a++instance (TestAction a) => MakeDefault (ObjRef (MockObj a)) where+ makeDef = do+ statusRef <- newIORef $ TestStatus [] (Just TInvalid)+ (TestEnv badSerial IntMap.empty IntMap.empty) IntMap.empty+ newObject $ MockObj badSerial statusRef++instance MakeDefault () where+ makeDef = return ()++instance MakeDefault Int32 where+ makeDef = return 0++instance MakeDefault Double where+ makeDef = return (0/0)++instance MakeDefault [a] where+ makeDef = return []++instance MakeDefault Text where+ makeDef = return T.empty++instance MakeDefault URI where+ makeDef = return $ URI "" Nothing "" "" ""++expectAction :: (TestAction a, MakeDefault b) =>+ MockObj a -> (a -> IO (Either TestFault b)) -> IO b+expectAction mock pred = do+ status <- readIORef $ mockStatus mock+ res <- case status of+ TestStatus (b:_) Nothing env _ -> case b of+ TestBox _ a -> case cast a of+ Just a' -> pred a' >>= return . fmap ((,) (updateEnvRaw a' env))+ _ -> return $ Left TBadActionType+ TestStatus [] Nothing _ _ -> return $ Left TOverAction+ TestStatus _ (Just f) _ _ -> return $ Left f+ case res of+ Left f -> do+ let (TestStatus bs _ env objs) = status+ writeIORef (mockStatus mock) $ TestStatus bs (Just f) env objs+ makeDef+ Right (env', v) -> do+ let (TestStatus (_:bs) _ _ objs) = status+ writeIORef (mockStatus mock) $ TestStatus bs Nothing env' objs+ return v++expectActionRef :: (TestAction a, MakeDefault b) =>+ ObjRef (MockObj a) -> (a -> IO (Either TestFault b)) -> IO b+expectActionRef ref pred = expectAction (fromObjRef ref) pred++badAction :: (MakeDefault b) => MockObj a -> IO b+badAction mock = do+ status <- readIORef $ mockStatus mock+ writeIORef (mockStatus mock) $ status {testFault = Just TBadAction} + makeDef++forkMockObj :: (TestAction b) => MockObj a -> IO (ObjRef (MockObj b))+forkMockObj m = do+ status <- mockGetStatus m+ newObject $ MockObj (testSerial status) $ mockStatus m++checkMockObj :: forall a b. (TestAction b) =>+ MockObj a -> MockObj b -> Int -> IO (Either TestFault ())+checkMockObj m v w = do+ status <- mockGetStatus m+ case IntMap.lookup w $ envJs $ testEnv status of+ Just entry -> if entry == (TestType (Proxy :: Proxy b), mockSerial v)+ then return $ Right ()+ else return $ Left TBadActionData+ _ -> return $ Left TBadActionSlot++instance (TestAction a) => Object (MockObj a) where+ classDef = defClass mockObjDef++instance (TestAction a) => Marshal (MockObj a) where+ type MarshalMode (MockObj a) = ValObjToOnly (MockObj a)+ marshaller = objSimpleMarshaller
+ test/Graphics/QML/Test/GenURI.hs view
@@ -0,0 +1,51 @@+module Graphics.QML.Test.GenURI where++import Test.QuickCheck.Gen+import Network.URI+import Numeric++capSize :: Int -> Gen a -> Gen a+capSize cap g = sized (\s -> if s > cap then resize cap g else resize s g)++uriGen :: Gen URI+uriGen = capSize 35 $ do+ let slists = fmap (:[])+ listxyz = fmap concat . sequence+ listxs = fmap concat . listOf+ listxs1 = fmap concat . listOf1+ lower = elements $ slists $ enumFromTo 'a' 'z'+ upper = elements $ slists $ enumFromTo 'A' 'Z'+ digit = elements $ slists "01234567989"+ mark = elements $ slists "-_.!~*'()"+ sextra = elements $ slists "+-."+ rextra = elements $ slists "$,;:@&=+"+ dash = return "-"+ dot = return "."+ alpha = oneof [lower, upper]+ alphnum = oneof [lower, upper, digit]+ dchar = oneof [lower, digit]+ dchar2 = frequency [(9,lower), (5,digit), (1,dash)]+ unres = frequency [(9,alphnum), (1,mark)]+ escNum = oneof [choose (0,31), choose (128,255)] :: Gen Int+ pad = \n x -> replicate (n - length x) '0' ++ x+ escape = fmap (('%':) . pad 2 . flip showHex "") escNum+ scheme = listxyz [alpha, listxs $ frequency [+ (9,alphnum), (1,sextra)]]+ dpart1 = listxyz [+ frequency [(9,dchar), (1,listxyz [dchar, dot, dchar])],+ listxs $ frequency [+ (9,dchar2), (1,listxyz [dchar, dot, dchar]),+ (1,listxyz [dchar, dot, dchar, dot, dchar])],+ dchar, dot]+ dpart2 = oneof [lower, listxyz [lower, listxs dchar2, dchar]]+ regName = flip suchThat (\x -> length x < 255) $ listxyz [+ frequency [(9,dpart1), (1,return "")],+ dpart2, oneof [dot, return ""]]+ segment = fmap ('/':) $ listxs $ frequency [+ (9,unres), (1,escape), (1,rextra)]+ path = listxs1 segment+ schemeStr <- scheme+ regNameStr <- regName+ pathStr <- path+ return $+ URI (schemeStr++":") (Just $ URIAuth "" regNameStr "") pathStr "" ""
+ test/Graphics/QML/Test/Harness.hs view
@@ -0,0 +1,75 @@+module Graphics.QML.Test.Harness where++import Graphics.QML.Test.Framework++import Test.QuickCheck+import Test.QuickCheck.Monadic+import Test.QuickCheck.Test++import Graphics.QML+import Data.IORef+import Data.Proxy+import Data.Typeable+import Data.Maybe+import System.IO+import System.Directory++qmlPrelude :: String+qmlPrelude = unlines [+ "import Qt 4.7",+ "Rectangle {",+ " id: page;",+ " width: 100; height: 100;",+ " color: 'green';",+ " Component.onCompleted: {"]++qmlPostscript :: String+qmlPostscript = unlines [+ " }",+ "}"]++finishTest :: MockObj a -> IO ()+finishTest mock = do+ let statusRef = mockStatus mock+ status <- readIORef statusRef+ let status' = case status of+ TestStatus (_:_) Nothing _ _ -> status {+ testFault = Just TUnderAction}+ _ -> status+ writeIORef statusRef status'++runTest :: (TestAction a) => TestBoxSrc a -> IO TestStatus+runTest src = do+ let js = showTestCode (srcTestBoxes src) ""+ tmpDir <- getTemporaryDirectory+ (qmlPath, hndl) <- openTempFile tmpDir "test1-.qml"+ hPutStr hndl (qmlPrelude ++ js ++ qmlPostscript)+ hClose hndl+ mock <- mockFromSrc src+ go <- newObject mock+ runEngineLoop defaultEngineConfig {+ initialURL = filePathToURI qmlPath,+ initialWindowState = HideWindow,+ contextObject = Just $ anyObjRef go}+ removeFile qmlPath+ finishTest mock+ status <- readIORef (mockStatus mock)+ if isJust $ testFault status+ then putStrLn $ show status+ else return ()+ return status++testProperty :: (TestAction a) => TestBoxSrc a -> Property+testProperty src = monadicIO $ do+ status <- run $ runTest src+ assert $ isNothing $ testFault status+ return ()++checkProperty :: TestType -> IO Bool+checkProperty (TestType pxy) = do+ putStrLn $ "Checking " ++ show (typeOf $ asProxyTypeOf undefined pxy)+ r <- quickCheckResult $ testProperty . constrainSrc pxy+ return $ isSuccess r++constrainSrc :: (TestAction a) => Proxy a -> TestBoxSrc a -> TestBoxSrc a+constrainSrc = flip const
+ test/Graphics/QML/Test/MayGen.hs view
@@ -0,0 +1,33 @@+module Graphics.QML.Test.MayGen where++import Test.QuickCheck.Gen+import Control.Applicative+import Data.Maybe++-- I wanted so badly to write a Monad instance for MayGen, but actually+-- Applicative captures the legal operations perfectly.++newtype MayGen a = MayGen {mayGen :: Maybe (Gen a)}++instance Functor MayGen where+ fmap f (MayGen v) = MayGen $ (fmap . fmap) f v++instance Applicative MayGen where+ pure = MayGen . Just . return+ (MayGen mf) <*> (MayGen v) = MayGen $ liftA2 (<*>) mf v++noGen :: MayGen a+noGen = MayGen Nothing++fromGen :: Gen a -> MayGen a+fromGen = MayGen . Just++mayElements :: [a] -> MayGen a+mayElements [] = noGen+mayElements xs = fromGen $ elements xs++mayOneof :: [MayGen a] -> MayGen a+mayOneof xs =+ case mapMaybe mayGen xs of+ [] -> noGen+ xs' -> fromGen $ oneof xs'
+ test/Graphics/QML/Test/MixedTest.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}++module Graphics.QML.Test.MixedTest where++import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Gen+import Control.Applicative+import Data.Typeable+import Data.Proxy++data ObjectA+ = OANewB Int+ | OACheckB Int+ deriving (Show, Typeable)++objectAType :: TestType+objectAType = TestType (Proxy :: Proxy ObjectA)++data ObjectB+ = OBNewA Int+ | OBCheckA Int+ deriving (Show, Typeable)++objectBType :: TestType+objectBType = TestType (Proxy :: Proxy ObjectB)++instance TestAction ObjectA where+ legalActionIn (OANewB n) env = testEnvIsaJ n objectBType env+ legalActionIn _ _ = True+ nextActionsFor env = mayOneof [+ OANewB <$> (fromGen $ choose (1, testEnvNextJ env)),+ OACheckB <$> mayElements (filter (/= 0) $ testEnvListJ objectBType env)]+ updateEnvRaw (OANewB n) = testEnvStep . testEnvSerial (\s ->+ testEnvSetJ n objectBType s)+ updateEnvRaw _ = testEnvStep+ actionRemote (OANewB v) n =+ S.saveVar v $ S.var n `S.dot` "newB" `S.call` []+ actionRemote (OACheckB v) n =+ S.eval $ S.var n `S.dot` "checkB" `S.call` [S.var v]+ mockObjDef = [+ defMethod "newB" $ \m -> expectAction m $ \a -> case a of+ OANewB _ -> do+ obj <- forkMockObj m+ return $ Right (obj :: ObjRef (MockObj ObjectB))+ _ -> return $ Left TBadActionCtor,+ defMethod "checkB" $ \m v -> expectAction m $ \a -> case a of+ OACheckB w -> checkMockObj m (v :: MockObj ObjectB) w+ _ -> return $ Left TBadActionCtor]++instance TestAction ObjectB where+ legalActionIn (OBNewA n) env = testEnvIsaJ n objectAType env+ legalActionIn _ _ = True+ nextActionsFor env = mayOneof [+ OBNewA <$> (fromGen $ choose (1, testEnvNextJ env)),+ OBCheckA <$> mayElements (filter (/= 0) $ testEnvListJ objectAType env)]+ updateEnvRaw (OBNewA n) = testEnvStep . testEnvSerial (\s ->+ testEnvSetJ n objectAType s)+ updateEnvRaw _ = testEnvStep+ actionRemote (OBNewA v) n =+ S.saveVar v $ S.var n `S.dot` "newA" `S.call` []+ actionRemote (OBCheckA v) n =+ S.eval $ S.var n `S.dot` "checkA" `S.call` [S.var v]+ mockObjDef = [+ defMethod "newA" $ \m -> expectAction m $ \a -> case a of+ OBNewA _ -> do+ obj <- forkMockObj m+ return $ Right (obj :: ObjRef (MockObj ObjectA))+ _ -> return $ Left TBadActionCtor,+ defMethod "checkA" $ \m v -> expectAction m $ \a -> case a of+ OBCheckA w -> checkMockObj m (v :: MockObj ObjectA) w+ _ -> return $ Left TBadActionCtor]
+ test/Graphics/QML/Test/ScriptDSL.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE FlexibleInstances #-}++module Graphics.QML.Test.ScriptDSL where++import Data.Char+import Data.Int+import Data.List+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI+import Numeric++data Expr = Global | Expr {unExpr :: ShowS}++data Prog = Prog ShowS ShowS++instance Monoid Prog where+ mempty = Prog id id+ mappend (Prog a1 b1) (Prog a2 b2) = Prog (a1 . a2) (b2 . b1)++showProg :: Prog -> ShowS+showProg (Prog a b) = a . b++class Literal a where+ literal :: a -> Expr++instance Literal Int where+ literal x = Expr $ shows x++instance Literal Int32 where+ literal x = Expr $ shows x++instance Literal Double where+ literal x | isNaN x = Expr $ showString "(0/0)"+ | isInfinite x && (x < 0) = Expr $ showString "(-1/0)"+ | isInfinite x = Expr $ showString "(1/0)"+ | isNegativeZero x = Expr $ showString "-0"+ | otherwise = Expr $ shows x++instance Literal [Char] where+ literal [] = Expr $ showString "\"\""+ literal cs =+ Expr (showChar '"' . (foldr1 (.) $ map f cs) . showChar '"')+ where f '\"' = showString "\\\""+ f '\\' = showString "\\\\"+ f c | ord c < 32 = hexEsc c+ | ord c > 127 = hexEsc c+ | otherwise = showChar c+ hexEsc c = let h = showHex (ord c)+ in showString "\\u" . showString (+ replicate (4 - (length $ h "")) '0') . h++instance Literal Text where+ literal = literal . T.unpack++instance Literal URI where+ literal = literal . ($ "") . uriToString id++var :: Int -> Expr+var 0 = Global+var n = Expr (showChar 'x' . shows n)++sym :: String -> Expr+sym name = Expr $ showString name++dot :: Expr -> String -> Expr+dot Global m = Expr $ showString m+dot (Expr lhs) m = Expr (lhs . showChar '.' . showString m)++call :: Expr -> [Expr] -> Expr+call (Expr f) ps = Expr (+ f . showChar '(' . (+ foldr1 (.) $ (id:) $ intersperse (showChar ',') $ map unExpr ps) .+ showChar ')')+call _ _ = error "cannot call the context object"++binOp :: String -> Expr -> Expr -> Expr+binOp op (Expr lhs) (Expr rhs) = Expr (+ showChar '(' . lhs . showString op . rhs . showChar ')')+binOp _ _ _ = error "cannot operate on the context object"++eq :: Expr -> Expr -> Expr+eq = binOp " == "++neq :: Expr -> Expr -> Expr+neq = binOp " != "++eval :: Expr -> Prog+eval (Expr ex) = Prog (ex . showString ";\n") id+eval _ = error "cannot eval the context object"++set :: Expr -> Expr -> Prog+set (Expr lhs) (Expr rhs) =+ Prog (lhs . showString " = " . rhs . showString ";\n") id+set _ _ = error "cannot set the context object"++saveVar :: Int -> Expr -> Prog+saveVar v (Expr rhs) =+ Prog (showString "var x" . shows v . showString " = " .+ rhs . showString ";\n") id+saveVar _ _ = error "cannot save the context object"++assert :: Expr -> Prog+assert (Expr ex) =+ Prog (showString "if (!" . ex .+ showString ") {window.close(); throw -1;}\n") id+assert _ = error "cannot assert the context object"++connect :: Expr -> Expr -> Prog+connect sig fn = eval $ sig `dot` "connect" `call` [fn]++disconnect :: Expr -> Expr -> Prog+disconnect sig fn = eval $ sig `dot` "disconnect" `call` [fn]++makeCont :: [String] -> Prog -> Prog -> Prog+makeCont args (Prog a1 b1) (Prog a2 b2) =+ Prog (showString "var cont = function(" . farg . showString ") {\n" . a2)+ (b2 . showString "};\n" . a1 . b1)+ where farg = foldr1 (.) $ (id:) $ intersperse (showChar ',') $+ map showString args++contVar :: Expr+contVar = sym "cont"++callee :: Expr+callee = sym "arguments.callee"++end :: Prog+end = Prog (showString "window.close();\n") id
+ test/Graphics/QML/Test/SignalTest.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies #-}++module Graphics.QML.Test.SignalTest where++import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen+import Graphics.QML.Test.GenURI+import Graphics.QML.Test.TestObject+import Graphics.QML.Test.ScriptDSL (Expr, Prog)+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Arbitrary+import Control.Applicative+import Data.Monoid+import Data.Tagged+import Data.Typeable++import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI++data SignalTest1+ = ST1TrivialMethod+ | ST1FireNoArgs+ | ST1FireInt Int32+ | ST1FireThreeInts Int32 Int32 Int32+ | ST1FireDouble Double+ | ST1FireString String+ | ST1FireText Text+ | ST1FireURI URI+ | ST1FireObject Int+ | ST1CheckObject Int+ deriving (Show, Typeable)++data NoArgsSignal deriving Typeable++instance SignalKey NoArgsSignal where+ type SignalParams NoArgsSignal = IO ()++data IntSignal deriving Typeable++instance SignalKey IntSignal where+ type SignalParams IntSignal = Int32 -> IO ()++data ThreeIntsSignal deriving Typeable++instance SignalKey ThreeIntsSignal where+ type SignalParams ThreeIntsSignal = Int32 -> Int32 -> Int32 -> IO ()++data DoubleSignal deriving Typeable++instance SignalKey DoubleSignal where+ type SignalParams DoubleSignal = Double -> IO ()++data StringSignal deriving Typeable++instance SignalKey StringSignal where+ type SignalParams StringSignal = String -> IO ()++data TextSignal deriving Typeable++instance SignalKey TextSignal where+ type SignalParams TextSignal = Text -> IO ()++data URISignal deriving Typeable++instance SignalKey URISignal where+ type SignalParams URISignal = URI -> IO ()++data ObjectSignal deriving Typeable++instance SignalKey ObjectSignal where+ type SignalParams ObjectSignal = ObjRef (MockObj TestObject) -> IO ()++chainSignal :: Int -> [String] -> String -> String -> Prog+chainSignal n args sig fn = S.makeCont args+ ((S.connect (S.var n `S.dot` sig) S.contVar) `mappend` + (S.eval $ (S.var n) `S.dot` fn `S.call` []))+ (S.disconnect (S.var n `S.dot` sig) S.callee)++testSignal :: Int -> String -> String -> Expr -> Prog+testSignal n sig fn v =+ chainSignal n ["arg"] sig fn `mappend`+ (S.assert $ S.sym "arg" `S.eq` v)++instance TestAction SignalTest1 where+ legalActionIn _ _ = True+ nextActionsFor env = mayOneof [+ pure ST1TrivialMethod,+ pure ST1FireNoArgs,+ ST1FireInt <$> fromGen arbitrary,+ ST1FireThreeInts <$>+ fromGen arbitrary <*> fromGen arbitrary <*> fromGen arbitrary,+ ST1FireDouble <$> fromGen arbitrary,+ ST1FireString <$> fromGen arbitrary,+ ST1FireText . T.pack <$> fromGen arbitrary,+ ST1FireURI <$> fromGen uriGen,+ pure . ST1FireObject $ testEnvNextJ env,+ ST1CheckObject <$> mayElements (testEnvListJ testObjectType env)]+ updateEnvRaw (ST1FireObject n) = testEnvStep . testEnvSerial (\s ->+ testEnvSetJ n testObjectType s)+ updateEnvRaw _ = testEnvStep+ actionRemote ST1TrivialMethod n =+ S.eval $ (S.var n) `S.dot` "trivialMethod" `S.call` []+ actionRemote ST1FireNoArgs n =+ chainSignal n [] "noArgsSignal" "fireNoArgs"+ actionRemote (ST1FireInt v) n =+ testSignal n "intSignal" "fireInt" $ S.literal v+ actionRemote (ST1FireThreeInts v1 v2 v3) n =+ chainSignal n ["arg1","arg2","arg3"]+ "threeIntsSignal" "fireThreeInts" `mappend`+ (S.assert $ S.sym "arg1" `S.eq` S.literal v1) `mappend`+ (S.assert $ S.sym "arg2" `S.eq` S.literal v2) `mappend`+ (S.assert $ S.sym "arg3" `S.eq` S.literal v3)+ actionRemote (ST1FireDouble v) n =+ testSignal n "doubleSignal" "fireDouble" $ S.literal v+ actionRemote (ST1FireString v) n =+ testSignal n "stringSignal" "fireString" $ S.literal v+ actionRemote (ST1FireText v) n =+ testSignal n "textSignal" "fireText" $ S.literal v+ actionRemote (ST1FireURI v) n =+ testSignal n "uriSignal" "fireURI" $ S.literal v+ actionRemote (ST1FireObject v) n =+ chainSignal n ["obj"] "objectSignal" "fireObject" `mappend`+ (S.saveVar v $ S.sym "obj")+ actionRemote (ST1CheckObject v) n =+ S.eval $ (S.var n) `S.dot` "checkObject" `S.call` [S.var v]+ mockObjDef = [+ defMethod "trivialMethod" $ \m -> expectAction m $ \a -> case a of+ ST1TrivialMethod -> return $ Right ()+ _ -> return $ Left TBadActionCtor,+ defMethod "fireNoArgs" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireNoArgs -> do+ fireSignal (Tagged m+ :: Tagged NoArgsSignal (ObjRef (MockObj SignalTest1)))+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "noArgsSignal" :: Tagged NoArgsSignal String), + defMethod "fireInt" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireInt v -> do+ fireSignal (Tagged m+ :: Tagged IntSignal (ObjRef (MockObj SignalTest1))) v+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "intSignal" :: Tagged IntSignal String),+ defMethod "fireThreeInts" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireThreeInts v1 v2 v3 -> do+ fireSignal (Tagged m+ :: Tagged ThreeIntsSignal (ObjRef (MockObj SignalTest1)))+ v1 v2 v3+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "threeIntsSignal" ::+ Tagged ThreeIntsSignal String),+ defMethod "fireDouble" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireDouble v -> do+ fireSignal (Tagged m+ :: Tagged DoubleSignal (ObjRef (MockObj SignalTest1))) v+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "doubleSignal" :: Tagged DoubleSignal String),+ defMethod "fireString" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireString v -> do+ fireSignal (Tagged m+ :: Tagged StringSignal (ObjRef (MockObj SignalTest1))) v+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "stringSignal" :: Tagged StringSignal String),+ defMethod "fireText" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireText v -> do+ fireSignal (Tagged m+ :: Tagged TextSignal (ObjRef (MockObj SignalTest1))) v+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "textSignal" :: Tagged TextSignal String),+ defMethod "fireURI" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireURI v -> do+ fireSignal (Tagged m+ :: Tagged URISignal (ObjRef (MockObj SignalTest1))) v+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "uriSignal" :: Tagged URISignal String),+ defMethod "fireObject" $ \m -> (expectActionRef m $ \a -> case a of+ ST1FireObject _ -> do+ (Right obj) <- getTestObject $ fromObjRef m+ fireSignal (Tagged m+ :: Tagged ObjectSignal (ObjRef (MockObj SignalTest1))) obj+ return $ Right ()+ _ -> return $ Left TBadActionCtor),+ defSignal (Tagged "objectSignal" :: Tagged ObjectSignal String),+ defMethod "checkObject" $ \m v -> expectAction m $ \a -> case a of+ ST1CheckObject w -> setTestObject m v w+ _ -> return $ Left TBadActionCtor]
+ test/Graphics/QML/Test/SimpleTest.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}++module Graphics.QML.Test.SimpleTest where++import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen+import Graphics.QML.Test.GenURI+import Graphics.QML.Test.TestObject+import Graphics.QML.Test.ScriptDSL (Expr, Prog)+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Arbitrary+import Control.Applicative+import Data.Typeable++import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Network.URI++makeCall :: Int -> String -> [Expr] -> Prog+makeCall n name es = S.eval $ S.var n `S.dot` name `S.call` es++saveCall :: Int -> Int -> String -> [Expr] -> Prog+saveCall v n name es = S.saveVar v $ S.var n `S.dot` name `S.call` es++testCall :: Int -> String -> [Expr] -> Expr -> Prog+testCall n name es r = S.assert $ S.eq (S.var n `S.dot` name `S.call` es) r++setProp :: Int -> String -> Expr -> Prog+setProp n name ex = S.set (S.var n `S.dot` name) ex++saveProp :: Int -> Int -> String -> Prog+saveProp v n name = S.saveVar v $ S.var n `S.dot` name++testProp :: Int -> String -> Expr -> Prog+testProp n name r = S.assert $ S.eq (S.var n `S.dot` name) r++checkArg :: (Show a, Eq a) => a -> a -> IO (Either TestFault ())+checkArg v w = return $+ if v == w then Right () else Left TBadActionData++data SimpleMethods+ = SMTrivial+ | SMTernary Int32 Int32 Int32 Int32+ | SMGetInt Int32+ | SMSetInt Int32+ | SMGetDouble Double+ | SMSetDouble Double+ | SMGetString String+ | SMSetString String+ | SMGetText Text+ | SMSetText Text+ | SMGetURI URI+ | SMSetURI URI+ | SMGetObject Int+ | SMSetObject Int+ deriving (Show, Typeable)++instance TestAction SimpleMethods where+ legalActionIn (SMSetObject n) env = testEnvIsaJ n testObjectType env+ legalActionIn _ _ = True+ nextActionsFor env = mayOneof [+ pure SMTrivial,+ SMTernary <$> + fromGen arbitrary <*> fromGen arbitrary <*>+ fromGen arbitrary <*> fromGen arbitrary,+ SMGetInt <$> fromGen arbitrary,+ SMSetInt <$> fromGen arbitrary,+ SMGetDouble <$> fromGen arbitrary,+ SMSetDouble <$> fromGen arbitrary,+ SMGetString <$> fromGen arbitrary,+ SMSetString <$> fromGen arbitrary,+ SMGetText . T.pack <$> fromGen arbitrary,+ SMSetText . T.pack <$> fromGen arbitrary,+ SMGetURI <$> fromGen uriGen,+ SMSetURI <$> fromGen uriGen,+ pure . SMGetObject $ testEnvNextJ env,+ SMSetObject <$> mayElements (testEnvListJ testObjectType env)]+ updateEnvRaw (SMGetObject n) = testEnvStep . testEnvSerial (\s ->+ testEnvSetJ n testObjectType s)+ updateEnvRaw _ = testEnvStep+ actionRemote SMTrivial n = makeCall n "trivial" []+ actionRemote (SMTernary v1 v2 v3 v4) n = testCall n "ternary" [+ S.literal v1, S.literal v2, S.literal v3] $ S.literal v4+ actionRemote (SMGetInt v) n = testCall n "getInt" [] $ S.literal v+ actionRemote (SMSetInt v) n = makeCall n "setInt" [S.literal v]+ actionRemote (SMGetDouble v) n = testCall n "getDouble" [] $ S.literal v+ actionRemote (SMSetDouble v) n = makeCall n "setDouble" [S.literal v]+ actionRemote (SMGetString v) n = testCall n "getString" [] $ S.literal v+ actionRemote (SMSetString v) n = makeCall n "setString" [S.literal v]+ actionRemote (SMGetText v) n = testCall n "getText" [] $ S.literal v+ actionRemote (SMSetText v) n = makeCall n "setText" [S.literal v]+ actionRemote (SMGetURI v) n = testCall n "getURI" [] $ S.literal v+ actionRemote (SMSetURI v) n = makeCall n "setURI" [S.literal v]+ actionRemote (SMGetObject v) n = saveCall v n "getObject" []+ actionRemote (SMSetObject v) n = makeCall n "setObject" [S.var v]+ mockObjDef = [+ defMethod "trivial" $ \m -> expectAction m $ \a -> case a of+ SMTrivial -> return $ Right ()+ _ -> return $ Left TBadActionCtor,+ defMethod "ternary" $ \m v1 v2 v3 -> expectAction m $ \a -> case a of+ SMTernary w1 w2 w3 w4 ->+ (fmap . fmap) (const w4) $ checkArg (v1,v2,v3) (w1,w2,w3)+ _ -> return $ Left TBadActionCtor,+ defMethod "getInt" $ \m -> expectAction m $ \a -> case a of+ SMGetInt v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "setInt" $ \m v -> expectAction m $ \a -> case a of+ SMSetInt w -> checkArg v w+ _ -> return $ Left TBadActionCtor,+ defMethod "getDouble" $ \m -> expectAction m $ \a -> case a of+ SMGetDouble v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "setDouble" $ \m v -> expectAction m $ \a -> case a of+ SMSetDouble w -> checkArg v w+ _ -> return $ Left TBadActionCtor,+ defMethod "getString" $ \m -> expectAction m $ \a -> case a of+ SMGetString v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "setString" $ \m v -> expectAction m $ \a -> case a of+ SMSetString w -> checkArg v w+ _ -> return $ Left TBadActionCtor,+ defMethod "getText" $ \m -> expectAction m $ \a -> case a of+ SMGetText v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "setText" $ \m v -> expectAction m $ \a -> case a of+ SMSetText w -> checkArg v w+ _ -> return $ Left TBadActionCtor,+ defMethod "getURI" $ \m -> expectAction m $ \a -> case a of+ SMGetURI v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "setURI" $ \m v -> expectAction m $ \a -> case a of+ SMSetURI w -> checkArg v w+ _ -> return $ Left TBadActionCtor,+ defMethod "getObject" $ \m -> expectAction m $ \a -> case a of+ SMGetObject _ -> getTestObject m+ _ -> return $ Left TBadActionCtor,+ defMethod "setObject" $ \m v -> expectAction m $ \a -> case a of+ SMSetObject w -> setTestObject m v w+ _ -> return $ Left TBadActionCtor]++data SimpleProperties+ = SPGetIntRO Int32+ | SPGetInt Int32+ | SPSetInt Int32+ | SPGetDouble Double+ | SPSetDouble Double+ | SPGetString String+ | SPSetString String+ | SPGetText Text+ | SPSetText Text+ | SPGetURI URI+ | SPSetURI URI+ | SPGetObject Int+ | SPSetObject Int+ deriving (Show, Typeable)++instance TestAction SimpleProperties where+ legalActionIn (SPSetObject n) env = testEnvIsaJ n testObjectType env+ legalActionIn _ _ = True+ nextActionsFor env = mayOneof [+ SPGetIntRO <$> fromGen arbitrary,+ SPGetInt <$> fromGen arbitrary,+ SPSetInt <$> fromGen arbitrary,+ SPGetDouble <$> fromGen arbitrary,+ SPSetDouble <$> fromGen arbitrary,+ SPGetString <$> fromGen arbitrary,+ SPSetString <$> fromGen arbitrary,+ SPGetText . T.pack <$> fromGen arbitrary,+ SPSetText . T.pack <$> fromGen arbitrary,+ SPGetURI <$> fromGen uriGen,+ SPSetURI <$> fromGen uriGen,+ pure . SPGetObject $ testEnvNextJ env,+ SPSetObject <$> mayElements (testEnvListJ testObjectType env)]+ updateEnvRaw (SPGetObject n) = testEnvStep . testEnvSerial (\s ->+ testEnvSetJ n testObjectType s)+ updateEnvRaw _ = testEnvStep+ actionRemote (SPGetIntRO v) n = testProp n "propIntRO" $ S.literal v+ actionRemote (SPGetInt v) n = testProp n "propIntR" $ S.literal v+ actionRemote (SPSetInt v) n = setProp n "propIntW" $ S.literal v+ actionRemote (SPGetDouble v) n = testProp n "propDoubleR" $ S.literal v+ actionRemote (SPSetDouble v) n = setProp n "propDoubleW" $ S.literal v+ actionRemote (SPGetString v) n = testProp n "propStringR" $ S.literal v+ actionRemote (SPSetString v) n = setProp n "propStringW" $ S.literal v+ actionRemote (SPGetText v) n = testProp n "propTextR" $ S.literal v+ actionRemote (SPSetText v) n = setProp n "propTextW" $ S.literal v+ actionRemote (SPGetURI v) n = testProp n "propURIR" $ S.literal v+ actionRemote (SPSetURI v) n = setProp n "propURIW" $ S.literal v+ actionRemote (SPGetObject v) n = saveProp v n "propObjectR"+ actionRemote (SPSetObject v) n = setProp n "propObjectW" $ S.var v+ mockObjDef = [+ -- There are seperate properties for testing accessors and mutators+ -- becasue QML produces spurious reads when writing.+ defPropertyRO "propIntRO"+ (\m -> expectAction m $ \a -> case a of+ SPGetIntRO v -> return $ Right v+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propIntR"+ (\m -> expectAction m $ \a -> case a of+ SPGetInt v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propIntW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetInt w -> checkArg v w+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propDoubleR"+ (\m -> expectAction m $ \a -> case a of+ SPGetDouble v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propDoubleW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetDouble w -> checkArg v w+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propStringR"+ (\m -> expectAction m $ \a -> case a of+ SPGetString v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propStringW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetString w -> checkArg v w+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propTextR"+ (\m -> expectAction m $ \a -> case a of+ SPGetText v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propTextW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetText w -> checkArg v w+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propURIR"+ (\m -> expectAction m $ \a -> case a of+ SPGetURI v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propURIW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetURI w -> checkArg v w+ _ -> return $ Left TBadActionCtor),+ defPropertyRW "propObjectR"+ (\m -> expectAction m $ \a -> case a of+ SPGetObject _ -> getTestObject m+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "propObjectW"+ (\_ -> makeDef)+ (\m v -> expectAction m $ \a -> case a of+ SPSetObject w -> setTestObject m (fromObjRef v) w+ _ -> return $ Left TBadActionCtor)]
+ test/Graphics/QML/Test/TestObject.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}++module Graphics.QML.Test.TestObject where++import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen++import Data.Typeable+import Data.Proxy++data TestObject deriving Typeable++testObjectType :: TestType+testObjectType = TestType (Proxy :: Proxy TestObject)++getTestObject ::+ MockObj a -> IO (Either TestFault (ObjRef (MockObj TestObject)))+getTestObject = fmap Right . forkMockObj++setTestObject ::+ MockObj a -> MockObj TestObject -> Int -> IO (Either TestFault ())+setTestObject = checkMockObj++instance Show TestObject where+ showsPrec _ = error "TestObject has no actions."++instance TestAction TestObject where+ legalActionIn _ _ = error "TestObject has no actions."+ nextActionsFor _ = noGen+ updateEnvRaw _ e = e+ actionRemote _ _ = error "TestObject has no actions."+ mockObjDef = []
test/Test1.hs view
@@ -1,148 +1,22 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-} module Main where -import Graphics.QML-import Control.Monad-import Data.IORef-import Data.List-import Data.Maybe-import Data.Typeable-import Network.URI+import Graphics.QML.Test.Framework+import Graphics.QML.Test.Harness+import Graphics.QML.Test.SimpleTest+import Graphics.QML.Test.SignalTest+import Graphics.QML.Test.MixedTest+import Data.Proxy import System.Exit-import System.IO-import System.Directory -data HarnessObject = HarnessObject {- globalState :: IORef [String]-} deriving Typeable--markTaskComplete :: HarnessObject -> String -> IO ()-markTaskComplete go task = do- let ref = globalState go- list <- readIORef ref- if elem task list- then do- putStrLn (- showString "Completed task '" .- showString task $ showString "'." [])- writeIORef ref $ delete task list- else do- putStrLn (showString "Unexpected task '" .- showString task $ showString "' completed." [])- writeIORef ref $ ("unexpected_" ++ task) : list--testInt :: Int-testInt = 8888--testDouble :: Double-testDouble = 0.25--testString :: String-testString = "我係QuickBrownFox"--testURI :: URI-testURI =- URI "http:" (Just $ URIAuth "" "www.example.com" "")- "/with space" "" "#test"--data TestObject = TestObject deriving (Eq, Typeable)--instance Object TestObject where- classDef = defClass []--instance MarshalIn TestObject where- mIn = objectInMarshaller--instance Object HarnessObject where- classDef = defClass [- defMethod "getInt" (\go -> do- markTaskComplete (fromObjRef go) "getInt"- return testInt),- defMethod "setInt" (\go i -> do- markTaskComplete (fromObjRef go) "setInt"- if (i == testInt)- then markTaskComplete (fromObjRef go) "setIntCorrect"- else return ()),- defMethod "getDouble" (\go -> do- markTaskComplete (fromObjRef go) "getDouble"- return testDouble),- defMethod "setDouble" (\go i -> do- markTaskComplete (fromObjRef go) "setDouble"- if (i == testDouble)- then markTaskComplete (fromObjRef go) "setDoubleCorrect"- else return ()),- defMethod "getString" (\go -> do- markTaskComplete (fromObjRef go) "getString"- return testString),- defMethod "setString" (\go i -> do- markTaskComplete (fromObjRef go) "setString"- if (i == testString)- then markTaskComplete (fromObjRef go) "setStringCorrect"- else return ()),- defMethod "getURI" (\go -> do- markTaskComplete (fromObjRef go) "getURI"- return testURI),- defMethod "setURI" (\go i -> do- markTaskComplete (fromObjRef go) "setURI"- if (i == testURI)- then markTaskComplete (fromObjRef go) "setURICorrect"- else return ()),- defMethod "getObject" (\go -> do- markTaskComplete (fromObjRef go) "getObject"- newObject TestObject),- defMethod "setObject" (\go i -> do- markTaskComplete (fromObjRef go) "setObject"- if (i == TestObject)- then markTaskComplete (fromObjRef go) "setObjectCorrect"- else return ())]--testScript :: String-testScript = unlines [- "import Qt 4.7",- "Rectangle {",- " id: page;",- " width: 100; height: 100;",- " color: 'green';",- " Component.onCompleted: {",- " var intVar = getInt();",- " setInt(intVar);",- " var dblVar = getDouble();",- " setDouble(dblVar);",- " var strVar = getString();",- " setString(strVar);",- " var uriVar = getURI();",- " setURI(uriVar);",- " var objVar = getObject();",- " setObject(objVar);",- " window.close();",- " }",- "}"]--testTasks :: [String]-testTasks = [- "getInt", "setInt", "setIntCorrect",- "getDouble", "setDouble", "setDoubleCorrect",- "getString", "setString", "setStringCorrect",- "getURI", "setURI", "setURICorrect",- "getObject", "setObject", "setObjectCorrect"]- main :: IO () main = do- tmpDir <- getTemporaryDirectory- (qmlPath, hndl) <- openTempFile tmpDir "test1-.qml"- hPutStr hndl testScript- hClose hndl- list <- newIORef testTasks- go <- newObject $ HarnessObject list- createEngine defaultEngineConfig {- initialURL = filePathToURI qmlPath,- contextObject = Just go}- runEngines- removeFile qmlPath- ts <- readIORef list- forM_ ts (\t -> putStrLn (- showString "Incomplete task '" . showString t $ showString "'." []))- if null ts+ rs <- sequence [+ checkProperty $ TestType (Proxy :: Proxy SimpleMethods),+ checkProperty $ TestType (Proxy :: Proxy SimpleProperties),+ checkProperty $ TestType (Proxy :: Proxy SignalTest1),+ checkProperty $ TestType (Proxy :: Proxy ObjectA)]+ if and rs then exitSuccess else exitFailure