packages feed

hsqml 0.3.1.1 → 0.3.2.0

raw patch · 24 files changed

+1410/−277 lines, 24 filesdep ~text

Dependency ranges changed: text

Files

CHANGELOG view
@@ -1,5 +1,14 @@ HsQML - Release History +release-0.3.2.0 - 2014.11.13++  * Added OpenGL canvas support.+  * Added weak references and object finalisers.+  * Added FactoryPool abstraction.+  * Added To-only custom marshallers.+  * Added Ignored type.+  * Relaxed Cabal dependency constraint on 'text'.+ release-0.3.1.1 - 2014.07.31    * Fixed crash when storing Haskell objects in QML variants.
cbits/Canvas.cpp view
@@ -1,29 +1,325 @@ #include "Canvas.h"-#include "CanvasImpl.h"+#include "Manager.h" -HsQMLGLDelegate::HsQMLGLDelegate(-    HsQMLGLPaintCb paintCb)-    : mImpl(new HsQMLGLDelegateImpl(paintCb))+#include <QtCore/qmath.h>+#include <QtQuick/QSGSimpleTextureNode>+#include <QtQuick/QSGTexture>+#include <QtQuick/QSGTransformNode>+#include <QtQuick/QQuickWindow>++HsQMLGLCallbacks::HsQMLGLCallbacks(+    HsQMLGLSetupCb setupCb, HsQMLGLCleanupCb cleanupCb,+    HsQMLGLSyncCb syncCb, HsQMLGLPaintCb paintCb)+    : mSetupCb(setupCb)+    , mCleanupCb(cleanupCb)+    , mSyncCb(syncCb)+    , mPaintCb(paintCb)+{}++HsQMLGLCallbacks::~HsQMLGLCallbacks() {+    gManager->freeFun(reinterpret_cast<HsFunPtr>(mSyncCb));+    gManager->freeFun(reinterpret_cast<HsFunPtr>(mPaintCb)); } +HsQMLGLDelegateImpl::HsQMLGLDelegateImpl(HsQMLGLMakeCallbacksCb makeContextCb)+    : mMakeCallbacksCb(makeContextCb)+{}++HsQMLGLDelegateImpl::~HsQMLGLDelegateImpl()+{+    gManager->freeFun(reinterpret_cast<HsFunPtr>(mMakeCallbacksCb));+}++HsQMLGLDelegate::HsQMLGLDelegate()+{+}+ HsQMLGLDelegate::~HsQMLGLDelegate() { } +void HsQMLGLDelegate::setup(HsQMLGLMakeCallbacksCb makeContextCb)+{+    mImpl = new HsQMLGLDelegateImpl(makeContextCb);+}++HsQMLGLDelegate::CallbacksRef HsQMLGLDelegate::makeCallbacks()+{+    CallbacksRef dataPtr;+    if (mImpl) {+        HsQMLGLSetupCb setupCb;+        HsQMLGLCleanupCb cleanupCb;+        HsQMLGLSyncCb syncCb;+        HsQMLGLPaintCb paintCb;+        mImpl->mMakeCallbacksCb(&setupCb, &cleanupCb, &syncCb, &paintCb);+        dataPtr = new HsQMLGLCallbacks(setupCb, cleanupCb, syncCb, paintCb);+    }+    return dataPtr;+}++HsQMLWindowInfoImpl::HsQMLWindowInfoImpl(QQuickWindow* win)+    : mWin(win)+    , mBelowCount(0)+    , mBelowClear(false)+{}++HsQMLWindowInfo::HsQMLWindowInfo()+{}++HsQMLWindowInfo HsQMLWindowInfo::getWindowInfo(QQuickWindow* win)+{+    const char* propName = "_hsqml_window_info";+    HsQMLWindowInfo info = win->property(propName).value<HsQMLWindowInfo>();+    if (!info.mImpl) {+        info.mImpl = new HsQMLWindowInfoImpl(win);+        win->setProperty(propName, QVariant::fromValue(info));+    }+    return info;+}++void HsQMLWindowInfo::addBelow()+{+    Q_ASSERT(mImpl);+    if (0 == mImpl->mBelowCount++) {+        mImpl->mWin->setClearBeforeRendering(false);+    }+}++void HsQMLWindowInfo::removeBelow()+{+    Q_ASSERT(mImpl);+    if (0 == --mImpl->mBelowCount) {+        mImpl->mWin->setClearBeforeRendering(true);+    }+}++bool HsQMLWindowInfo::needsBelowClear()+{+    Q_ASSERT(mImpl);+    if (mImpl->mBelowCount && !mImpl->mBelowClear) {+        mImpl->mBelowClear = true;+        return true;+    }+    return false;+}++void HsQMLWindowInfo::endFrame()+{+    Q_ASSERT(mImpl);+    mImpl->mBelowClear = false;+}++HsQMLCanvasBackEnd::HsQMLCanvasBackEnd(+    QQuickWindow* win,+    const HsQMLGLDelegate::CallbacksRef& cbs,+    HsQMLCanvas::DisplayMode mode)+    : mWindow(win)+    , mWinInfo(HsQMLWindowInfo::getWindowInfo(win))+    , mGLCallbacks(cbs)+    , mGL(NULL)+    , mStatus(HsQMLCanvas::Okay)+    , mDisplayMode(mode)+    , mItemWidth(0)+    , mItemHeight(0)+    , mTransformNode(NULL)+    , mCanvasWidth(0)+    , mCanvasHeight(0)+{+    if (HsQMLCanvas::Above == mDisplayMode) {+        QObject::connect(+            win, SIGNAL(afterRendering()),+            this, SLOT(doRendering()));+    }+    else {+        QObject::connect(+            win, SIGNAL(beforeRendering()),+            this, SLOT(doRendering()));++        if (HsQMLCanvas::Below == mDisplayMode) {+            mWinInfo.addBelow();+            QObject::connect(+                win, SIGNAL(frameSwapped()),+                this, SLOT(doEndFrame()));+        }+    }+}++HsQMLCanvasBackEnd::~HsQMLCanvasBackEnd()+{+    if (HsQMLCanvas::Below == mDisplayMode) {+        mWinInfo.removeBelow();+    }+}++void HsQMLCanvasBackEnd::setTransformNode(+    QSGTransformNode* tn, qreal w, qreal h)+{+    mTransformNode = tn;+    mItemWidth = w;+    mItemHeight = h;+}++QSGTexture* HsQMLCanvasBackEnd::updateFBO(qreal w, qreal h)+{+    if (HsQMLCanvas::Inline == mDisplayMode) {+        if (!mFBO || w != mCanvasWidth || h != mCanvasHeight) {+            mCanvasWidth = w;+            mCanvasHeight = h;+            QSize dims(qCeil(mCanvasWidth), qCeil(mCanvasHeight));+            mFBO.reset(new QOpenGLFramebufferObject(+                dims, QOpenGLFramebufferObject::Depth));+            mTexture.reset(mWindow->createTextureFromId(+                mFBO->texture(), dims, QQuickWindow::TextureHasAlphaChannel));+        }+    }+    else {+        mTexture.reset();+        mFBO.reset();+    }+    return mTexture.data();+}++HsQMLCanvas::Status HsQMLCanvasBackEnd::status() const+{+    return mStatus;+}++void HsQMLCanvasBackEnd::setStatus(HsQMLCanvas::Status status)+{+    bool change = mStatus != status;+    mStatus = status;+    if (change) {+        statusChanged(mStatus);+    }+}++void HsQMLCanvasBackEnd::doRendering()+{+    if (!mGL) {+        mGL = mWindow->openglContext();+        QObject::connect(+            mGL, SIGNAL(aboutToBeDestroyed()), this, SLOT(doCleanup()));+        HsQMLGLCanvasType ctype;+        QSurfaceFormat format = mGL->format();+        switch (format.renderableType()) {+            case QSurfaceFormat::OpenGL: ctype = HSQML_GL_DESKTOP; break;+            case QSurfaceFormat::OpenGLES: ctype = HSQML_GL_ES; break;+            default: setStatus(HsQMLCanvas::BadConfig); return;+        }+        mGLViewportFn = reinterpret_cast<GLViewportFn>(+            mGL->getProcAddress("glViewport"));+        mGLClearColorFn = reinterpret_cast<GLClearColorFn>(+            mGL->getProcAddress("glClearColor"));+        mGLClearFn = reinterpret_cast<GLClearFn>(+            mGL->getProcAddress("glClear"));+        if (!mGLViewportFn || !mGLClearColorFn || !mGLClearFn) {+            setStatus(HsQMLCanvas::BadProcs);+            return;+        }+        mGLCallbacks->mSetupCb(+            ctype, format.majorVersion(), format.minorVersion());+    }++    // Reset OpenGL state before rendering+#if QT_VERSION >= 0x050200+    mWindow->resetOpenGLState();+#else+#warning Resetting OpenGL state requires Qt 5.2 or later+#endif++    // Clear window if painting below the scenegraph+    if (mWinInfo.needsBelowClear()) {+        QColor bg = mWindow->color();+        mGLClearColorFn(bg.redF(), bg.greenF(), bg.blueF(), bg.alphaF());+        mGLClearFn(GL_COLOR_BUFFER_BIT);+    }++    // Setup prior to paint callback+    QMatrix4x4 matrix;+    bool inlineMode = HsQMLCanvas::Inline == mDisplayMode;+    if (inlineMode) {+        if (!mFBO->bind()) {+            setStatus(HsQMLCanvas::BadBind);+            return;+        }+        mGLViewportFn(0, 0, qCeil(mCanvasWidth), qCeil(mCanvasHeight));++        // Clear FBO to transparent+        mGLClearColorFn(0, 0, 0, 0);+        mGLClearFn(GL_COLOR_BUFFER_BIT);+    }+    else {+        // Calculate matrix for non-inline display modes+        QMatrix4x4 smatrix;+        QSGNode* node = mTransformNode;+        while (node) {+            if (QSGNode::TransformNodeType == node->type()) {+                QSGTransformNode* tnode = static_cast<QSGTransformNode*>(node);+                smatrix = tnode->matrix() * smatrix;+            }+            node = node->parent();+        }+        matrix.translate(-1, 1);+        matrix.scale(2.0f/mWindow->width(), -2.0f/mWindow->height());+        matrix *= smatrix;+        matrix.scale(mItemWidth/2.0f, mItemHeight/2.0f);+        matrix.translate(1, 1);++        mGLViewportFn(0, 0, mWindow->width(), mWindow->height());+    }++    setStatus(HsQMLCanvas::Okay);+    mGLCallbacks->mPaintCb(matrix.data(), mItemWidth, mItemHeight);++    if (inlineMode) {+        mFBO->release();+    }+}++void HsQMLCanvasBackEnd::doEndFrame()+{+    mWinInfo.endFrame();+}++void HsQMLCanvasBackEnd::doCleanup()+{+    if (mGL) {+        mGL->makeCurrent(mWindow);+        mGL = NULL;++        mTexture.reset();+        mFBO.reset();++        mGLCallbacks->mCleanupCb();+    }+}++void HsQMLCanvasBackEnd::doCleanupKill()+{+    doCleanup();+    delete this;+}+ HsQMLCanvas::HsQMLCanvas(QQuickItem* parent)     : QQuickItem(parent)     , mWindow(NULL)     , mBackEnd(NULL)+    , mStatus(Okay)+    , mFrontStatus(Okay)+    , mBackStatus(Okay)     , mDisplayMode(Inline)     , mCanvasWidth(0)     , mCanvasWidthSet(false)     , mCanvasHeight(0)     , mCanvasHeightSet(false)+    , mLoadModel(false)+    , mValidModel(false) {     QObject::connect(         this, SIGNAL(windowChanged(QQuickWindow*)),         this, SLOT(doWindowChanged(QQuickWindow*)));+    setFlag(ItemHasContents, true); }  HsQMLCanvas::~HsQMLCanvas()@@ -39,14 +335,86 @@     if (!mCanvasHeightSet) {         setCanvasHeight(rect.height(), false);     }+    update(); } +QSGNode* HsQMLCanvas::updatePaintNode(+    QSGNode* oldNode, UpdatePaintNodeData* paintData)+{+    // Window always needs repainting+    mWindow->update();++    // Lazily create new callbacks+    if (!mGLCallbacks) {+        mGLCallbacks = mDelegate.value<HsQMLGLDelegate>().makeCallbacks();+        mLoadModel = true;+        mValidModel = false;++        // Display nothing without a valid delegate+        if (!mGLCallbacks) {+            setStatus(BadDelegate);+            delete oldNode;+            return NULL;+        }+    }++    // Process model update+    if (mLoadModel) {+        mValidModel = mGLCallbacks->mSyncCb(+            reinterpret_cast<HsQMLJValHandle*>(&mModel));+        mLoadModel = false;+    }++    // Display nothing if there's no valid model+    if (!mValidModel) {+        setStatus(BadModel);+        detachBackEnd();+        delete oldNode;+        return NULL;+    }++    // Create back-end on the rendering thread+    if (!mBackEnd) {+        mBackEnd = new HsQMLCanvasBackEnd(mWindow, mGLCallbacks, mDisplayMode);++        // Monitor back-end's status+        QObject::connect(+            mBackEnd, SIGNAL(statusChanged(HsQMLCanvas::Status)),+            this, SLOT(doBackEndStatusChanged(HsQMLCanvas::Status)));+        setStatus(mBackEnd->status(), true);+    }+    setStatus(Okay);++    // Save pointer to transform node+    mBackEnd->setTransformNode(+        Inline != mDisplayMode ? paintData->transformNode : NULL,+        width(), height());++    // Produce texture node if needed+    if (QSGTexture* texture =+            mBackEnd->updateFBO(mCanvasWidth, mCanvasHeight)) {+        QSGSimpleTextureNode* n = static_cast<QSGSimpleTextureNode*>(oldNode);+        if (!n) {+            n = new QSGSimpleTextureNode();+        }+        n->setRect(0, 0, width(), height());+        n->setTexture(texture);+        return n;+    }++    delete oldNode;+    return NULL;+}+ void HsQMLCanvas::detachBackEnd() {     if (mBackEnd) {         // The back-end belongs to the rendering thread-        mBackEnd->deleteLater();+        QMetaObject::invokeMethod(+            mBackEnd, "doCleanupKill", Qt::QueuedConnection);+        QObject::disconnect(mBackEnd, 0, this, 0);         mBackEnd = NULL;+        mGLCallbacks.reset();     } } @@ -60,7 +428,9 @@     bool change = mDisplayMode != mode;     mDisplayMode = mode;     if (change) {+        detachBackEnd();         displayModeChanged();+        update();     } } @@ -76,6 +446,7 @@     mCanvasWidthSet |= set;     if (change) {         canvasWidthChanged();+        update();     } } @@ -97,6 +468,7 @@     mCanvasHeightSet |= set;     if (change) {         canvasHeightChanged();+        update();     } } @@ -106,37 +478,104 @@     setCanvasHeight(height(), false); } -void HsQMLCanvas::doWindowChanged(QQuickWindow* win)+QVariant HsQMLCanvas::delegate() const {-    if (mWindow) {-        QObject::disconnect(mWindow, NULL, this, NULL);+    return mDelegate;+}++void HsQMLCanvas::setDelegate(const QVariant& d)+{+    bool change = mDelegate != d;+    mDelegate = d;+    if (change) {         detachBackEnd();+        delegateChanged();+        update();     }-    mWindow = win;-    if (mWindow) {-        QObject::connect(-            mWindow, SIGNAL(beforeSynchronizing()),-            this, SLOT(doPreSynchronise()), Qt::DirectConnection);+}++QJSValue HsQMLCanvas::model() const+{+    return mModel;+}++void HsQMLCanvas::setModel(const QJSValue& m)+{+    bool change = !mModel.strictlyEquals(m);+    mModel = m;+    if (change) {+        modelChanged();+        mLoadModel = true;+        update();     } } -void HsQMLCanvas::doPreSynchronise()+HsQMLCanvas::Status HsQMLCanvas::status() const {-    // This executes on the rendering thread-    if (!mBackEnd) {-        mBackEnd = new HsQMLCanvasBackEnd(mWindow);+    return mStatus;+}++void HsQMLCanvas::setStatus(Status status, bool backEnd)+{+    if (backEnd) {+        mBackStatus = status;     }-    mBackEnd->setModeSize(mDisplayMode, mCanvasWidth, mCanvasHeight);+    else {+        mFrontStatus = status;+    }+    Status newStatus = mFrontStatus == Okay ? mBackStatus : mFrontStatus;+    bool change = mStatus != newStatus;+    if (change) {+        statusChanged();+    } } -HsQMLGLControl::HsQMLGLControl(QQuickItem* parent)-    : QQuickItem(parent)-{}+void HsQMLCanvas::doWindowChanged(QQuickWindow* win)+{+    detachBackEnd();+    mWindow = win;+} -void hsqml_init_jval_gldelegate(-    HsQMLJValHandle* hndl,-    HsQMLGLPaintCb paintCb)+void HsQMLCanvas::doBackEndStatusChanged(Status status) {-    QJSValue* value = reinterpret_cast<QJSValue*>(hndl);-    HsQMLGLDelegate delegate(paintCb);+    setStatus(status, true);+}++HsQMLGLDelegateHandle* hsqml_create_gldelegate()+{+    return reinterpret_cast<HsQMLGLDelegateHandle*>(new HsQMLGLDelegate());+}++void hsqml_finalise_gldelegate_handle(+    HsQMLGLDelegateHandle* hndl)+{+    HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+    delete delegate;+}++void hsqml_gldelegate_setup(+    HsQMLGLDelegateHandle* hndl,+    HsQMLGLMakeCallbacksCb makeContextCb)+{+    HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+    delegate->setup(makeContextCb);+}++void hsqml_gldelegate_to_jval(+    HsQMLGLDelegateHandle* hndl,+    HsQMLJValHandle* jhndl)+{+    HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+    new((void*)jhndl) QJSValue(+        gManager->activeEngine()->declEngine()->toScriptValue(*delegate));+}++void hsqml_gldelegate_from_jval(+    HsQMLGLDelegateHandle* hndl,+    HsQMLJValHandle* jhndl)+{+    HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+    QJSValue* value = reinterpret_cast<QJSValue*>(jhndl);+    *delegate = gManager->activeEngine()->declEngine()->+        fromScriptValue<HsQMLGLDelegate>(*value);  }
cbits/Canvas.h view
@@ -1,27 +1,93 @@ #ifndef HSQML_CANVAS_H #define HSQML_CANVAS_H +#include <QtCore/QObject> #include <QtCore/QExplicitlySharedDataPointer>+#include <QtCore/QMetaType>+#include <QtCore/QScopedPointer>+#include <QtCore/QSharedData>+#include <QtGui/qopengl.h>+#include <QtGui/QOpenGLContext>+#include <QtGui/QOpenGLFramebufferObject> #include <QtQuick/QQuickItem>  #include "hsqml.h" +class QSGTexture;+class QSGTransformNode;+class QQuickWindow; class HsQMLCanvasBackEnd;-class HsQMLGLDelegateImpl;+class HsQMLWindowInfoImpl; +class HsQMLGLCallbacks : public QSharedData+{+public:+    HsQMLGLCallbacks(+        HsQMLGLSetupCb, HsQMLGLCleanupCb, HsQMLGLSyncCb, HsQMLGLPaintCb);+    ~HsQMLGLCallbacks();++    HsQMLGLSetupCb mSetupCb;+    HsQMLGLCleanupCb mCleanupCb;+    HsQMLGLSyncCb mSyncCb;+    HsQMLGLPaintCb mPaintCb;+};++class HsQMLGLDelegateImpl : public QSharedData+{+public:+    HsQMLGLDelegateImpl(HsQMLGLMakeCallbacksCb);+    ~HsQMLGLDelegateImpl();++    HsQMLGLMakeCallbacksCb mMakeCallbacksCb;+};+ class HsQMLGLDelegate { public:-    HsQMLGLDelegate(HsQMLGLPaintCb);+    HsQMLGLDelegate();     ~HsQMLGLDelegate();+    void setup(HsQMLGLMakeCallbacksCb);+    typedef QExplicitlySharedDataPointer<HsQMLGLCallbacks> CallbacksRef;+    CallbacksRef makeCallbacks();  private:     QExplicitlySharedDataPointer<HsQMLGLDelegateImpl> mImpl; }; +Q_DECLARE_METATYPE(HsQMLGLDelegate)++class HsQMLWindowInfoImpl : public QSharedData+{+public:+    HsQMLWindowInfoImpl(QQuickWindow*);+    +private:+    friend class HsQMLWindowInfo;+    QQuickWindow* mWin;+    int mBelowCount;+    bool mBelowClear;+};++class HsQMLWindowInfo+{+public:+    HsQMLWindowInfo();+    static HsQMLWindowInfo getWindowInfo(QQuickWindow*);+    void addBelow();+    void removeBelow();+    bool needsBelowClear();+    void endFrame();++private:+    QExplicitlySharedDataPointer<HsQMLWindowInfoImpl> mImpl;+};++Q_DECLARE_METATYPE(HsQMLWindowInfo)+ class HsQMLCanvas : public QQuickItem {     Q_OBJECT+    Q_ENUMS(Status)     Q_ENUMS(DisplayMode)     Q_PROPERTY(DisplayMode displayMode READ displayMode WRITE setDisplayMode         NOTIFY displayModeChanged)@@ -29,8 +95,14 @@         RESET unsetCanvasWidth NOTIFY canvasWidthChanged)     Q_PROPERTY(qreal canvasHeight READ canvasHeight WRITE setCanvasHeight         RESET unsetCanvasHeight NOTIFY canvasHeightChanged)+    Q_PROPERTY(QVariant delegate READ delegate WRITE setDelegate+        NOTIFY delegateChanged)+    Q_PROPERTY(QJSValue model READ model WRITE setModel+        NOTIFY modelChanged)+    Q_PROPERTY(Status status READ status NOTIFY statusChanged)  public:+    enum Status {Okay, BadDelegate, BadModel, BadConfig, BadProcs, BadBind};     enum DisplayMode {Above, Below, Inline};      HsQMLCanvas(QQuickItem* = NULL);@@ -40,6 +112,7 @@     Q_DISABLE_COPY(HsQMLCanvas);      void geometryChanged(const QRectF&, const QRectF&) Q_DECL_OVERRIDE;+    QSGNode* updatePaintNode(QSGNode*, UpdatePaintNodeData*) Q_DECL_OVERRIDE;     void detachBackEnd();     DisplayMode displayMode() const;     void setDisplayMode(DisplayMode);@@ -49,30 +122,82 @@     qreal canvasHeight() const;     void setCanvasHeight(qreal, bool = true);     void unsetCanvasHeight();+    QVariant delegate() const;+    void setDelegate(const QVariant&);+    QJSValue model() const;+    void setModel(const QJSValue&);+    Status status() const;+    void setStatus(Status, bool = false);     Q_SIGNAL void displayModeChanged();     Q_SIGNAL void canvasWidthChanged();     Q_SIGNAL void canvasHeightChanged();+    Q_SIGNAL void delegateChanged();+    Q_SIGNAL void modelChanged();+    Q_SIGNAL void statusChanged();     Q_SLOT void doWindowChanged(QQuickWindow*);-    Q_SLOT void doPreSynchronise();+    Q_SLOT void doBackEndStatusChanged(HsQMLCanvas::Status);      QQuickWindow* mWindow;     HsQMLCanvasBackEnd* mBackEnd;+    Status mStatus;+    Status mFrontStatus;+    Status mBackStatus;     DisplayMode mDisplayMode;     qreal mCanvasWidth;     bool mCanvasWidthSet;     qreal mCanvasHeight;     bool mCanvasHeightSet;+    QVariant mDelegate;+    HsQMLGLDelegate::CallbacksRef mGLCallbacks;+    QJSValue mModel;+    bool mLoadModel;+    bool mValidModel; }; -class HsQMLGLControl : public QQuickItem+class HsQMLCanvasBackEnd : public QObject {     Q_OBJECT  public:-    HsQMLGLControl(QQuickItem* = NULL);+    HsQMLCanvasBackEnd(+        QQuickWindow*,+        const HsQMLGLDelegate::CallbacksRef&,+        HsQMLCanvas::DisplayMode);+    ~HsQMLCanvasBackEnd();+    void setTransformNode(QSGTransformNode*, qreal, qreal);+    QSGTexture* updateFBO(qreal, qreal);+    HsQMLCanvas::Status status() const;  private:-    Q_DISABLE_COPY(HsQMLGLControl);+    Q_DISABLE_COPY(HsQMLCanvasBackEnd)++    void setStatus(HsQMLCanvas::Status);+    Q_SLOT void doRendering();+    Q_SLOT void doEndFrame();+    Q_SLOT void doCleanup();+    Q_SLOT void doCleanupKill();+    Q_SIGNAL void statusChanged(HsQMLCanvas::Status);++    typedef void (*GLViewportFn)(GLint,GLint,GLsizei,GLsizei);+    typedef void (*GLClearColorFn)(GLclampf,GLclampf,GLclampf,GLclampf);+    typedef void (*GLClearFn)(GLbitfield);++    QQuickWindow* mWindow;+    HsQMLWindowInfo mWinInfo;+    HsQMLGLDelegate::CallbacksRef mGLCallbacks;+    QOpenGLContext* mGL;+    GLViewportFn mGLViewportFn;+    GLClearColorFn mGLClearColorFn;+    GLClearFn mGLClearFn;+    HsQMLCanvas::Status mStatus;+    HsQMLCanvas::DisplayMode mDisplayMode;+    qreal mItemWidth;+    qreal mItemHeight;+    QSGTransformNode* mTransformNode;+    qreal mCanvasWidth;+    qreal mCanvasHeight;+    QScopedPointer<QOpenGLFramebufferObject> mFBO;+    QScopedPointer<QSGTexture> mTexture; };  #endif //HSQML_CANVAS_H
− cbits/CanvasImpl.cpp 
@@ -1,56 +0,0 @@-#include <QtCore/qmath.h>--#include "CanvasImpl.h"-#include "Manager.h"--HsQMLGLDelegateImpl::HsQMLGLDelegateImpl(HsQMLGLPaintCb paintCb)-    : mPaintCb(paintCb)-{}--HsQMLGLDelegateImpl::~HsQMLGLDelegateImpl()-{-    gManager->freeFun(reinterpret_cast<HsFunPtr>(mPaintCb));-}--HsQMLCanvasBackEnd::HsQMLCanvasBackEnd(QQuickWindow* win)-{-    QObject::connect(-        win, SIGNAL(beforeRendering()),-        this, SLOT(doRendering()));-}--HsQMLCanvasBackEnd::~HsQMLCanvasBackEnd()-{-}--void HsQMLCanvasBackEnd::setModeSize(-    HsQMLCanvas::DisplayMode mode, qreal w, qreal h)-{-    mDisplayMode = mode;-    mCanvasWidth = w;-    mCanvasHeight = h;--    if (HsQMLCanvas::Inline == mode) {-        if (!mFBO || mFBO->width() != w || mFBO->height() != h) {-            mFBO.reset(new QOpenGLFramebufferObject(-                qCeil(w), qCeil(h), QOpenGLFramebufferObject::Depth));-        }-    }-    else {-        mFBO.reset();-    }-}--void HsQMLCanvasBackEnd::doRendering()-{-    bool inlineMode = HsQMLCanvas::Inline == mDisplayMode;-    if (inlineMode && !mFBO) {-        return;-    }-    if (inlineMode) {-        mFBO->bind();-    }-    if (inlineMode) {-        mFBO->release();-    }-}
− cbits/CanvasImpl.h 
@@ -1,41 +0,0 @@-#ifndef HSQML_CANVAS_IMPL_H-#define HSQML_CANVAS_IMPL_H--#include <QtCore/QObject>-#include <QtCore/QScopedPointer>-#include <QtCore/QSharedData>-#include <QtGui/QOpenGLFramebufferObject>-#include <QtQuick/QQuickWindow>--#include "Canvas.h"--class HsQMLGLDelegateImpl : public QSharedData-{-public:-    HsQMLGLDelegateImpl(HsQMLGLPaintCb);-    ~HsQMLGLDelegateImpl();--    HsQMLGLPaintCb mPaintCb;-};--class HsQMLCanvasBackEnd : public QObject-{-    Q_OBJECT--public:-    HsQMLCanvasBackEnd(QQuickWindow*);-    ~HsQMLCanvasBackEnd();-    void setModeSize(HsQMLCanvas::DisplayMode, qreal, qreal);--private:-    Q_DISABLE_COPY(HsQMLCanvasBackEnd)--    Q_SLOT void doRendering();--    HsQMLCanvas::DisplayMode mDisplayMode;-    qreal mCanvasWidth;-    qreal mCanvasHeight;-    QScopedPointer<QOpenGLFramebufferObject> mFBO;-};--#endif //HSQML_CANVAS_IMPL_H
cbits/Manager.cpp view
@@ -8,6 +8,7 @@ #include <pthread.h> #endif +#include "Canvas.h" #include "Manager.h" #include "Object.h" @@ -211,8 +212,9 @@         // Install hooked handler for QVariants         QVariantPrivate::registerHandler(0, &mHookedHandler); -        // Register custom type+        // Register custom types         qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");+        qmlRegisterType<HsQMLCanvas>("HsQML.Canvas", 1, 0, "HaskellCanvas");          // Create application object         mApp = new HsQMLManagerApp();
cbits/Object.cpp view
@@ -1,13 +1,28 @@ #include <HsFFI.h> #include <QtCore/QString>+#include <QtCore/QMutexLocker> #include <QtQml/QQmlEngine>  #include "Object.h" #include "Class.h" #include "Manager.h" -static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event", "Var"};+static const char* cRefSrcNames[] = {"Hndl", "Weak", "Obj", "Event", "Var"}; +HsQMLObjectFinaliser::HsQMLObjectFinaliser(HsQMLObjFinaliserCb cb)+    : mFinaliseCb(cb)+{}++HsQMLObjectFinaliser::~HsQMLObjectFinaliser()+{+    gManager->freeFun(reinterpret_cast<HsFunPtr>(mFinaliseCb));+}++void HsQMLObjectFinaliser::finalise(HsQMLObjectProxy* proxy) const+{+    mFinaliseCb(reinterpret_cast<HsQMLObjectHandle*>(proxy));+}+ HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)     : mHaskell(haskell)     , mKlass(klass)@@ -60,6 +75,7 @@         mKlass->name(), mSerial, mObject));      mObject = NULL;+    runFinalisers(); }  void HsQMLObjectProxy::tryGCLock()@@ -79,15 +95,43 @@ {     Q_ASSERT(gManager->isEventThread()); -    if (mObject && mHndlCount.loadAcquire() == 0 && mObject->isGCLocked()) {-        mObject->clearGCLock();+    if (mObject && mHndlCount.loadAcquire() == 0) {+        if (mObject->isGCLocked()) {+            mObject->clearGCLock(); -        HSQML_LOG(5,-            QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",-            mKlass->name(), mSerial, mObject));+            HSQML_LOG(5,+                QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",+                mKlass->name(), mSerial, mObject));+        }+        else {+            // If there had been a QML object then this would have happened+            // when the QML GC collected it.+            runFinalisers();+        }     } } +void HsQMLObjectProxy::addFinaliser(const HsQMLObjectFinaliser::Ref& f)+{+    QMutexLocker locker(&mFinaliseMutex);+    mFinalisers.append(f);+}++void HsQMLObjectProxy::runFinalisers()+{+    // Copy and clear finalisers under lock+    mFinaliseMutex.lock();+    const Finalisers fs = mFinalisers;+    mFinalisers.clear();+    mFinaliseMutex.unlock();++    // Call finalisers outside lock so they can re-addFinaliser()+    Q_FOREACH(const HsQMLObjectFinaliser::Ref& f, fs) {+        ref(Handle);+        f->finalise(this);+    }+}+ HsQMLEngine* HsQMLObjectProxy::engine() const {     if (mObject != NULL) {@@ -112,7 +156,7 @@  void HsQMLObjectProxy::deref(RefSrc src) {-    // Remove JavaScript GC lock when there are no handles+    // Remove JavaScript GC lock when there are no strong handles     if (src == Handle || src == Variant) {         int hndlCount = mHndlCount.fetchAndAddOrdered(-1);         if (hndlCount == 1 && mObject) {@@ -340,6 +384,14 @@     return hsqml_get_object_from_pointer(jval->toQObject()); } +extern void hsqml_object_reference_handle(+    HsQMLObjectHandle* hndl,+    int weak)+{+    HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+    proxy->ref(weak ? HsQMLObjectProxy::WeakHandle : HsQMLObjectProxy::Handle);+}+ extern void hsqml_finalise_object_handle(     HsQMLObjectHandle* hndl) {@@ -349,6 +401,15 @@     } } +extern void hsqml_finalise_object_weak_handle(+    HsQMLObjectHandle* hndl)+{+    if (hndl) {+        HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+        proxy->deref(HsQMLObjectProxy::WeakHandle);+    }+}+ extern void hsqml_fire_signal(     HsQMLObjectHandle* hndl, int idx, void** args) {@@ -362,4 +423,26 @@         HsQMLObject* obj = proxy->object(engine);         QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args);     }+}++extern HsQMLObjFinaliserHandle* hsqml_create_obj_finaliser(+    HsQMLObjFinaliserCb cb)+{+    return reinterpret_cast<HsQMLObjFinaliserHandle*>(+        new HsQMLObjectFinaliser::Ref(new HsQMLObjectFinaliser(cb)));+}++extern void hsqml_finalise_obj_finaliser(+    HsQMLObjFinaliserHandle* hndl)+{+    HsQMLObjectFinaliser::Ref* fp =+        reinterpret_cast<HsQMLObjectFinaliser::Ref*>(hndl);+    delete fp;+}++extern void hsqml_object_add_finaliser(+    HsQMLObjectHandle* hndl, HsQMLObjFinaliserHandle* fhndl)+{+    HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+    proxy->addFinaliser(*reinterpret_cast<HsQMLObjectFinaliser::Ref*>(fhndl)); }
cbits/Object.h view
@@ -4,12 +4,33 @@ #include <QtCore/QObject> #include <QtCore/QAtomicInt> #include <QtCore/QEvent>+#include <QtCore/QExplicitlySharedDataPointer>+#include <QtCore/QMutex>+#include <QtCore/QVarLengthArray> #include <QtQml/QJSValue> +#include "hsqml.h"+ class HsQMLEngine; class HsQMLClass; class HsQMLObject;+class HsQMLObjectProxy; +class HsQMLObjectFinaliser : public QSharedData+{+public:+    typedef QExplicitlySharedDataPointer<HsQMLObjectFinaliser> Ref;++    HsQMLObjectFinaliser(HsQMLObjFinaliserCb);+    ~HsQMLObjectFinaliser();+    void finalise(HsQMLObjectProxy*) const;++private:+    Q_DISABLE_COPY(HsQMLObjectFinaliser);++    HsQMLObjFinaliserCb mFinaliseCb;+};+ class HsQMLObjectProxy { public:@@ -21,18 +42,25 @@     void clearObject();     void tryGCLock();     void removeGCLock();+    void addFinaliser(const HsQMLObjectFinaliser::Ref&);+    void runFinalisers();     HsQMLEngine* engine() const;-    enum RefSrc {Handle, Object, Event, Variant};+    enum RefSrc {Handle, WeakHandle, Object, Event, Variant};     void ref(RefSrc);     void deref(RefSrc);  private:+    Q_DISABLE_COPY(HsQMLObjectProxy);+     HsStablePtr mHaskell;     HsQMLClass* mKlass;     int mSerial;     HsQMLObject* volatile mObject;     QAtomicInt mRefCount;     QAtomicInt mHndlCount;+    QMutex mFinaliseMutex;+    typedef QVarLengthArray<HsQMLObjectFinaliser::Ref, 1> Finalisers;+    Finalisers mFinalisers; };  class HsQMLObjectEvent : public QEvent@@ -62,6 +90,8 @@     HsQMLEngine* engine() const;  private:+    Q_DISABLE_COPY(HsQMLObject);+     HsQMLObjectProxy* mProxy;     HsStablePtr mHaskell;     HsQMLClass* mKlass;
cbits/hsqml.h view
@@ -162,17 +162,79 @@ extern HsQMLObjectHandle* hsqml_get_object_from_jval(     HsQMLJValHandle*); +extern void hsqml_object_reference_handle(+    HsQMLObjectHandle*, int);+ extern void hsqml_finalise_object_handle(     HsQMLObjectHandle*); +extern void hsqml_finalise_object_weak_handle(+    HsQMLObjectHandle*);+ extern void hsqml_fire_signal(     HsQMLObjectHandle*, int, void**); +/* Object Finaliser */+typedef char HsQMLObjFinaliserHandle;++typedef void (*HsQMLObjFinaliserCb)(HsQMLObjectHandle*);++extern HsQMLObjFinaliserHandle* hsqml_create_obj_finaliser(+    HsQMLObjFinaliserCb);++extern void hsqml_finalise_obj_finaliser(+    HsQMLObjFinaliserHandle*);++extern void hsqml_object_add_finaliser(+    HsQMLObjectHandle*, HsQMLObjFinaliserHandle*);+ /* Engine */ extern void hsqml_create_engine(     HsQMLObjectHandle*,     HsQMLStringHandle*,     HsQMLTrivialCb stopCb);++/* Canvas */+typedef char HsQMLGLDelegateHandle;++typedef enum {+    HSQML_GL_DESKTOP,+    HSQML_GL_ES+} HsQMLGLCanvasType;++typedef void (*HsQMLGLSetupCb)(+    HsQMLGLCanvasType, int, int);++typedef void (*HsQMLGLCleanupCb)();++typedef int (*HsQMLGLSyncCb)(+    HsQMLJValHandle*);++typedef void (*HsQMLGLPaintCb)(+    float*, float, float);++typedef void (*HsQMLGLMakeCallbacksCb)(+    HsQMLGLSetupCb*,+    HsQMLGLCleanupCb*,+    HsQMLGLSyncCb*,+    HsQMLGLPaintCb*);++extern HsQMLGLDelegateHandle* hsqml_create_gldelegate();++extern void hsqml_finalise_gldelegate_handle(+    HsQMLGLDelegateHandle*);++extern void hsqml_gldelegate_setup(+    HsQMLGLDelegateHandle*,+    HsQMLGLMakeCallbacksCb);++extern void hsqml_gldelegate_to_jval(+    HsQMLGLDelegateHandle*,+    HsQMLJValHandle*);++extern void hsqml_gldelegate_from_jval(+    HsQMLGLDelegateHandle*,+    HsQMLJValHandle*);  #ifdef __cplusplus }
hsqml.cabal view
@@ -1,5 +1,5 @@ Name:               hsqml-Version:            0.3.1.1+Version:            0.3.2.0 Cabal-version:      >= 1.14 Build-type:         Custom License:            BSD3@@ -41,25 +41,30 @@         base         == 4.*,         containers   >= 0.4 && < 0.6,         filepath     == 1.3.*,-        text         >= 0.11 && < 1.2,+        text         >= 0.11 && < 1.3,         tagged       >= 0.4 && < 0.8,         transformers >= 0.2 && < 0.5     Exposed-modules:         Graphics.QML         Graphics.QML.Debug+        Graphics.QML.Canvas         Graphics.QML.Engine         Graphics.QML.Marshal         Graphics.QML.Objects+        Graphics.QML.Objects.Weak     Other-modules:         Graphics.QML.Internal.BindPrim+        Graphics.QML.Internal.BindCanvas         Graphics.QML.Internal.BindObj         Graphics.QML.Internal.BindCore         Graphics.QML.Internal.JobQueue         Graphics.QML.Internal.Marshal         Graphics.QML.Internal.MetaObj+        Graphics.QML.Internal.Objects         Graphics.QML.Internal.Types     Hs-source-dirs: src     C-sources:+        cbits/Canvas.cpp         cbits/Class.cpp         cbits/Engine.cpp         cbits/Intrinsics.cpp@@ -67,6 +72,7 @@         cbits/Object.cpp     Include-dirs: cbits     X-moc-headers:+        cbits/Canvas.h         cbits/Engine.h         cbits/Manager.h     X-separate-cbits: True@@ -105,7 +111,7 @@         base       == 4.*,         containers >= 0.4 && < 0.6,         directory  >= 1.1 && < 1.3,-        text       >= 0.11 && < 1.2,+        text       >= 0.11 && < 1.3,         tagged     >= 0.4 && < 0.8,         QuickCheck >= 2.4 && < 2.8,         hsqml      == 0.3.*
src/Graphics/QML.hs view
@@ -19,9 +19,11 @@ -- * Graphics.QML   module Graphics.QML.Engine,   module Graphics.QML.Marshal,-  module Graphics.QML.Objects+  module Graphics.QML.Objects,+  module Graphics.QML.Objects.Weak ) where  import Graphics.QML.Engine import Graphics.QML.Marshal import Graphics.QML.Objects+import Graphics.QML.Objects.Weak
+ src/Graphics/QML/Canvas.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE+    ScopedTypeVariables,+    TypeFamilies,+    FlexibleInstances+  #-}++{-| Facility for drawing OpenGL graphics into the QML scenegraph.++To use this facility, you must place a @HaskellCanvas@ item into your+QML scene. This item can be imported from the @HsQML.Canvas 1.0@ namespace+using the @import@ statement in your QML script. It has several properties+which can be set from QML:++[@displayMode@] Specifies how the canvas is rendered with respect to the+rest of the scene. Possible values are:++    [@HaskellCanvas.Above@] The canvas shares a buffer with the scenegraph+    and is painted top of other items.+    [@HaskellCanvas.Inline@] The canvas has its own framebuffer object and the+    contents of this buffer are painted inline with other items (default).+    [@HaskellCanvas.Below@] The canvas shares a buffer with the scenegraph+    and is painted underneath other items.++[@canvasWidth@] Width of the framebuffer object in pixels. Defaults to the+item width.+[@canvasHeight@] Height of the framebuffer object in pixels. Defaults to the+item height.+[@delegate@] A marshalled 'OpenGLDelegate' value which specifies the Haskell+functions used to render the canvas.+[@model@] A value passed to delegate's paint function. The canvas is+repainted whenever this value changes.+[@status@] Either @HaskellCanvas.Okay@ or an error code (read only).+-}+module Graphics.QML.Canvas (+    OpenGLDelegate,+    newOpenGLDelegate,+    OpenGLType (+        OpenGLDesktop,+        OpenGLES),+    OpenGLSetup,+    openGLType,+    openGLMajor,+    openGLMinor,+    OpenGLPaint,+    OpenGLPaint',+    setupData,+    modelData,+    matrixPtr,+    itemWidth,+    itemHeight+) where++import Graphics.QML.Internal.BindCanvas+import Graphics.QML.Internal.BindPrim+import Graphics.QML.Internal.Marshal+import Graphics.QML.Marshal++import Data.IORef+import Data.Maybe+import Data.Tagged+import Control.Monad.Trans.Maybe+import Foreign.Ptr (Ptr)+import Foreign.C.Types (CFloat)++-- | Delegate for painting OpenGL graphics.+newtype OpenGLDelegate = OpenGLDelegate HsQMLGLDelegateHandle++instance Marshal OpenGLDelegate where+    type MarshalMode OpenGLDelegate c d = ModeBidi c+    marshaller = Marshaller {+        mTypeCVal_ = Tagged tyJSValue,+        mFromCVal_ = jvalFromCVal,+        mToCVal_ = jvalToCVal,+        mWithCVal_ = jvalWithCVal,+        mFromJVal_ = \ptr -> MaybeT $ do+            hndl <- hsqmlCreateGldelegate+            hsqmlGldelegateFromJval hndl ptr+            return $ Just $ OpenGLDelegate hndl,+        mWithJVal_ = \(OpenGLDelegate hndl) f ->+            withJVal (flip hsqmlGldelegateToJval) hndl f,+        mFromHndl_ = unimplFromHndl,+        mToHndl_ = unimplToHndl}++-- | Represents the type of an OpenGL context.+data OpenGLType+    -- | Desktop OpenGL context.+    = OpenGLDesktop+    -- | OpenGL ES context.+    | OpenGLES+    deriving (Eq, Show)++mapGLType :: HsQMLGLCanvasType -> OpenGLType+mapGLType HsqmlGlDesktop = OpenGLDesktop+mapGLType HsqmlGlEs      = OpenGLES++-- | Encapsulates parameters for OpenGL setup.+data OpenGLSetup = OpenGLSetup {+    -- | Type of OpenGL context.+    openGLType :: OpenGLType,+    -- | Major version number of OpenGL context.+    openGLMajor :: Int,+    -- | Minor version number of OpenGL context.+    openGLMinor :: Int+}++-- | Encapsulates parameters for OpenGL paint.+data OpenGLPaint s m = OpenGLPaint {+    -- | Gets the setup state.+    setupData  :: s,+    -- | Gets the active model.+    modelData :: m,+    -- | Pointer to a 4 by 4 matrix which transform coordinates in the range+    -- (-1, -1) to (1, 1) on to the target rectangle in the scene.+    matrixPtr :: Ptr CFloat,+    -- | Width of the canvas item in its local coordinate system.+    itemWidth :: Float,+    -- | Height of the canvas item in its local coordinate system.+    itemHeight :: Float+}++-- | Specialised version of `OpenGLPaint` with no model.+type OpenGLPaint' s = OpenGLPaint s Ignored++newOpenGLCallbacks :: (Marshal m, CanGetFrom m ~ Yes) =>+    (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->+    CallbacksFactory+newOpenGLCallbacks setupFn paintFn cleanupFn = do+    iRef <- newIORef Nothing+    mRef <- newIORef Nothing+    let setupCb ctype major minor = do+            iVal <- setupFn $ OpenGLSetup+                (mapGLType $ cIntToEnum ctype)+                (fromIntegral major) (fromIntegral minor)+            writeIORef iRef $ Just iVal+        cleanupCb = do+            iVal <- readIORef iRef+            cleanupFn $ fromJust iVal+        syncCb ptr = do+             mVal <- runMaybeT $ mFromJVal ptr+             writeIORef mRef mVal+             return $ if isJust mVal then 1 else 0+        paintCb mPtr w h = do+            iVal <- readIORef iRef+            mVal <- readIORef mRef+            paintFn $ OpenGLPaint+                (fromJust iVal) (fromJust mVal)+                mPtr (realToFrac w) (realToFrac h)+    return (setupCb, cleanupCb, syncCb, paintCb)++-- | Creates a new 'OpenGLDelegate' from setup, paint, and cleanup functions.+newOpenGLDelegate :: (Marshal m, CanGetFrom m ~ Yes) =>+    (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->+    IO OpenGLDelegate+newOpenGLDelegate setupFn paintFn cleanupFn = do+    hndl <- hsqmlCreateGldelegate+    hsqmlGldelegateSetup hndl (newOpenGLCallbacks setupFn paintFn cleanupFn)+    return $ OpenGLDelegate hndl
src/Graphics/QML/Engine.hs view
@@ -34,18 +34,16 @@ import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.BindCore-import Graphics.QML.Marshal+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 qualified Data.Text as T import Data.List-import Data.Maybe import Data.Traversable import Data.Typeable import Foreign.Ptr@@ -75,8 +73,8 @@     hsqmlInit     let obj = contextObject config         DocumentPath res = initialDocument config-    hndl <- sequenceA $ fmap mToHndl $ obj-    mWithCVal (T.pack res) $ \resPtr -> do+    hndl <- sequenceA $ fmap mToHndl obj+    mWithCVal (T.pack res) $ \resPtr ->         hsqmlCreateEngine hndl (HsQMLStringHandle $ castPtr resPtr) stopCb     return Engine @@ -101,8 +99,7 @@ -- | 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 ())+runEngineAsync config = RunQML $ 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@@ -116,7 +113,7 @@ newtype RunQML a = RunQML (IO a) deriving (Functor, Applicative, Monad)  instance MonadIO RunQML where-    liftIO io = RunQML io+    liftIO = RunQML  -- | 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@@ -138,7 +135,7 @@             ret <- try runFn             case ret of                 Left ex -> putMVar finishVar $ throwIO (ex :: SomeException)-                Right ret -> putMVar finishVar $ return ret+                Right ret' -> putMVar finishVar $ return ret'             hsqmlEvloopRelease         yieldCb = if rtsSupportsBoundThreads                   then Nothing@@ -151,7 +148,7 @@             finFn  tryRunInBoundThread :: IO a -> IO a-tryRunInBoundThread action = do+tryRunInBoundThread action =     if rtsSupportsBoundThreads     then runInBoundThread action     else action@@ -195,15 +192,15 @@ fileDocument :: FilePath -> DocumentPath fileDocument fp =     let ds = splitDirectories fp-        abs = isAbsolute fp+        isAbs = isAbsolute fp         fixHead =             (\cs -> if null cs then [] else '/':cs) .-            takeWhile (\c -> not $ c `elem` pathSeparators)+            takeWhile (`notElem` pathSeparators)         mapHead _ [] = []         mapHead f (x:xs) = f x : xs         afp = intercalate "/" $ mapHead fixHead ds         rfp = intercalate "/" ds-    in DocumentPath $ if abs then "file://" ++ afp else rfp+    in DocumentPath $ if isAbs then "file://" ++ afp else rfp  -- | Converts a URI string into a 'DocumentPath'. uriDocument :: String -> DocumentPath
+ src/Graphics/QML/Internal/BindCanvas.chs view
@@ -0,0 +1,88 @@+{-# LANGUAGE+    ForeignFunctionInterface+  #-}++module Graphics.QML.Internal.BindCanvas where++{#import Graphics.QML.Internal.BindPrim #}++import Foreign.C.Types+import Foreign.Ptr+import Foreign.ForeignPtr.Safe+import Foreign.Storable++#include "hsqml.h"++--+-- GL Delegate+--++{#pointer *HsQMLGLDelegateHandle as ^ foreign newtype #}++type SetupCb = CInt -> CInt -> CInt -> IO ()+type CleanupCb = IO ()+type SyncCb = HsQMLJValHandle -> IO CInt+type PaintCb = Ptr CFloat -> CFloat -> CFloat -> IO ()+type MakeCb = Ptr (FunPtr SetupCb) -> Ptr (FunPtr CleanupCb) ->+    Ptr (FunPtr SyncCb) -> Ptr (FunPtr PaintCb) -> IO ()+type CallbacksFactory = IO (SetupCb, CleanupCb, SyncCb, PaintCb)++{#enum HsQMLGLCanvasType as ^ {underscoreToCase} #}++foreign import ccall "wrapper"+  marshalSetupCb :: SetupCb -> IO (FunPtr SetupCb)++foreign import ccall "wrapper"+  marshalCleanupCb :: CleanupCb -> IO (FunPtr CleanupCb)++foreign import ccall "wrapper"  +  marshalSyncCb :: SyncCb -> IO (FunPtr SyncCb)++foreign import ccall "wrapper"  +  marshalPaintCb :: PaintCb -> IO (FunPtr PaintCb)++foreign import ccall "wrapper"+  marshalMakeCb :: MakeCb -> IO (FunPtr MakeCb)++withCallbacksFactory :: CallbacksFactory -> (FunPtr MakeCb -> IO a) -> IO a+withCallbacksFactory factory with = do+    let makeFn setupPtrFPtr cleanupPtrFPtr syncPtrFPtr paintPtrFPtr = do+            (setupFn, cleanupFn, syncFn, paintFn) <- factory+            setupFPtr <- marshalSetupCb setupFn+            poke setupPtrFPtr setupFPtr+            cleanupFPtr <- marshalCleanupCb cleanupFn+            poke cleanupPtrFPtr cleanupFPtr+            syncFPtr <- marshalSyncCb syncFn+            poke syncPtrFPtr syncFPtr+            paintFPtr <- marshalPaintCb paintFn+            poke paintPtrFPtr paintFPtr+    makeFPtr <- marshalMakeCb makeFn+    with makeFPtr++foreign import ccall "hsqml.h &hsqml_finalise_gldelegate_handle"+    hsqmlFinaliseGldelegateHandlePtr ::+        FunPtr (Ptr HsQMLGLDelegateHandle -> IO ())++newGLDelegateHandle :: Ptr HsQMLGLDelegateHandle -> IO HsQMLGLDelegateHandle+newGLDelegateHandle p = do+    fp <- newForeignPtr hsqmlFinaliseGldelegateHandlePtr p+    return $ HsQMLGLDelegateHandle fp++{#fun unsafe hsqml_create_gldelegate as ^+  {} ->+  `HsQMLGLDelegateHandle' newGLDelegateHandle* #}++{#fun unsafe hsqml_gldelegate_setup as ^+  {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+   withCallbacksFactory* `CallbacksFactory'} ->+  `()' #}++{#fun unsafe hsqml_gldelegate_to_jval as ^+  {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+   id `HsQMLJValHandle'} ->+  `()' #}++{#fun unsafe hsqml_gldelegate_from_jval as ^+  {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+   id `HsQMLJValHandle'} ->+  `()' #}
src/Graphics/QML/Internal/BindCore.chs view
@@ -9,10 +9,7 @@ {#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> @@ -47,9 +44,6 @@ withMaybeTrivialCb Nothing = \cont -> cont nullFunPtr  {#enum HsQMLEventLoopStatus as ^ {underscoreToCase} #}--cIntToEnum :: Enum a => CInt -> a-cIntToEnum = toEnum . fromIntegral  {#fun hsqml_evloop_run as ^   {withTrivialCb* `TrivialCb',
src/Graphics/QML/Internal/BindObj.chs view
@@ -10,7 +10,7 @@ import Control.Exception (bracket) import Control.Monad (void) import Foreign.C.Types-import Foreign.Marshal.Utils (toBool)+import Foreign.Marshal.Utils (fromBool, toBool) import Foreign.Ptr import Foreign.ForeignPtr.Safe import Foreign.ForeignPtr.Unsafe@@ -67,6 +67,9 @@ foreign import ccall "hsqml.h &hsqml_finalise_object_handle"   hsqmlFinaliseObjectHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ()) +foreign import ccall "hsqml.h &hsqml_finalise_object_weak_handle"+  hsqmlFinaliseObjectWeakHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ())+ newObjectHandle :: Ptr HsQMLObjectHandle -> IO HsQMLObjectHandle newObjectHandle p = do   fp <- newForeignPtr hsqmlFinaliseObjectHandlePtr p@@ -83,7 +86,7 @@  {#fun unsafe hsqml_object_set_active as ^   {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle'} ->- `Bool' toBool #}+  `Bool' toBool #}  withActiveObject :: HsQMLObjectHandle -> IO () -> IO () withActiveObject hndl action =@@ -116,8 +119,49 @@   {id `HsQMLJValHandle'} ->   `HsQMLObjectHandle' newObjectHandle* #} +{#fun unsafe hsqml_object_reference_handle as ^+  {id `Ptr HsQMLObjectHandle',+   fromBool `Bool'} ->+  `()' #}++copyObjectHandle :: HsQMLObjectHandle -> Bool -> IO HsQMLObjectHandle+copyObjectHandle (HsQMLObjectHandle fp) weak = do+    withForeignPtr fp $ \p -> do+        hsqmlObjectReferenceHandle p weak+        fp' <- newForeignPtr final p+        return $ HsQMLObjectHandle fp'+    where final = if weak+                  then hsqmlFinaliseObjectWeakHandlePtr+                  else hsqmlFinaliseObjectHandlePtr+ {#fun hsqml_fire_signal as ^   {withHsQMLObjectHandle* `HsQMLObjectHandle',    `Int',    id `Ptr (Ptr ())'} ->   `()' #}++{#pointer *HsQMLObjFinaliserHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_obj_finaliser"+  hsqmlFinaliseObjFinaliserPtr :: FunPtr (Ptr HsQMLObjFinaliserHandle -> IO ())++type ObjFinaliserFunc = Ptr HsQMLObjectHandle -> IO ()++foreign import ccall "wrapper"  +  marshalObjFinaliser :: ObjFinaliserFunc -> IO (FunPtr ObjFinaliserFunc)++newObjFinaliserHandle ::+    Ptr HsQMLObjFinaliserHandle -> IO HsQMLObjFinaliserHandle+newObjFinaliserHandle p = do+    fp <- newForeignPtr hsqmlFinaliseObjFinaliserPtr p+    return $ HsQMLObjFinaliserHandle fp++{#fun unsafe hsqml_create_obj_finaliser as ^+  {id `FunPtr ObjFinaliserFunc'} ->+  `HsQMLObjFinaliserHandle' newObjFinaliserHandle* #}++{#fun unsafe hsqml_object_add_finaliser as ^+  {withHsQMLObjectHandle* `HsQMLObjectHandle',+   withHsQMLObjFinaliserHandle* `HsQMLObjFinaliserHandle'} ->+  `()' #}+
src/Graphics/QML/Internal/BindPrim.chs view
@@ -12,8 +12,8 @@  #include "hsqml.h" -cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral+cIntToEnum :: Enum a => CInt -> a+cIntToEnum = toEnum . fromIntegral  -- -- String
src/Graphics/QML/Internal/Marshal.hs view
@@ -34,7 +34,7 @@ tyString  = TypeId 10 tyObject  = TypeId 39 tyVoid    = TypeId 43-tyJSValue = TypeId $ hsqmlJValTypeId+tyJSValue = TypeId hsqmlJValTypeId  type MTypeCValFunc t = Tagged t TypeId type MFromCValFunc t = Ptr () -> ErrIO t@@ -83,6 +83,14 @@ type instance ModeFrom IIsObjType = No type instance ModeFrom IGetObjType = No +-- | 'MarshalMode' for non-object types with to-only marshalling.+type family ModeTo c+type instance ModeTo ICanGetFrom = No+type instance ModeTo ICanPassTo = Yes+type instance ModeTo ICanReturnTo = Yes+type instance ModeTo IIsObjType = No+type instance ModeTo IGetObjType = No+ -- | 'MarshalMode' for void in method returns. type family ModeRetVoid c type instance ModeRetVoid ICanGetFrom = No@@ -107,6 +115,14 @@ type instance ModeObjFrom a IIsObjType = Yes type instance ModeObjFrom a IGetObjType = a +-- | 'MarshalMode' for object types with to-only marshalling.+type family ModeObjTo a c+type instance ModeObjTo a ICanGetFrom = No+type instance ModeObjTo a ICanPassTo = Yes+type instance ModeObjTo a ICanReturnTo = Yes+type instance ModeObjTo a IIsObjType = Yes+type instance ModeObjTo a IGetObjType = a+ -- | Type value indicating a capability is supported. data Yes @@ -191,35 +207,35 @@ mToHndl = mToHndl_ (marshaller :: MarshallerFor t)  unimplFromCVal :: MFromCValFunc t-unimplFromCVal = \_ -> error "Type does not support mFromCVal."+unimplFromCVal _ = error "Type does not support mFromCVal."  unimplToCVal :: MToCValFunc t-unimplToCVal = \_ _ -> error "Type does not support mToCVal."+unimplToCVal _ _ = error "Type does not support mToCVal."  unimplWithCVal :: MWithCValFunc t-unimplWithCVal = \_ _ -> error "Type does not support mWithCVal."+unimplWithCVal _ _ = error "Type does not support mWithCVal."  unimplFromJVal :: MFromJValFunc t-unimplFromJVal = \_ -> error "Type does not support mFromJVal."+unimplFromJVal _ = error "Type does not support mFromJVal."  unimplWithJVal :: MWithJValFunc t-unimplWithJVal = \_ _ -> error "Type does not support mWithJVal."+unimplWithJVal _ _ = error "Type does not support mWithJVal."  unimplFromHndl :: MFromHndlFunc t-unimplFromHndl = \_ -> error "Type does not support mFromHndl."+unimplFromHndl _ = error "Type does not support mFromHndl."  unimplToHndl :: MToHndlFunc t-unimplToHndl = \_ -> error "Type does not support mToHndl."+unimplToHndl _ = error "Type does not support mToHndl."  jvalFromCVal :: (Marshal t) => MFromCValFunc t jvalFromCVal = mFromJVal . HsQMLJValHandle . castPtr  jvalToCVal :: (Marshal t) => MToCValFunc t-jvalToCVal = \val ptr -> mWithJVal val $ \jval ->+jvalToCVal val ptr = mWithJVal val $ \jval ->     hsqmlSetJval (HsQMLJValHandle $ castPtr ptr) jval  jvalWithCVal :: (Marshal t) => MWithCValFunc t-jvalWithCVal = \val f -> mWithJVal val $ \(HsQMLJValHandle ptr) ->+jvalWithCVal val f = mWithJVal val $ \(HsQMLJValHandle ptr) ->     f $ castPtr ptr  instance Marshal () where
src/Graphics/QML/Internal/MetaObj.hs view
@@ -1,11 +1,9 @@ module Graphics.QML.Internal.MetaObj where -import Graphics.QML.Internal.BindObj-import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.Types  import Control.Monad-import Control.Monad.Trans.State+import Control.Monad.Trans.State (State, execState, get, put) import Data.Bits import Data.Map (Map) import qualified Data.Map as Map@@ -37,8 +35,8 @@ 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)+        rev []     vs m = (vs, m)+        rev (u:us) vs m = rev us (u:vs) (m+1)  crlToNewArray :: (Storable b) => (a -> IO b) -> CRList a -> IO (Ptr b) crlToNewArray f (CRList len lst) = do@@ -124,8 +122,7 @@   in enc  filterMembers :: MemberKind -> [Member tt] -> [Member tt]-filterMembers k ms =-  filter (\m -> k == memberKind m) ms+filterMembers k = filter (\m -> k == memberKind m)  newMOCState :: MOCState -> MOCState newMOCState enc = MOCState@@ -149,12 +146,12 @@   let msChr = mStrChar state       msInf = mStrInfo state       msMap = mStrMap state-  case (Map.lookup str msMap) of+  case Map.lookup str msMap of     Just idx -> writeInt idx     Nothing  -> do       let idx = crlLen msInf - 1-          msChr' = msChr `crlAppend` (map castCharToCChar str) `crlAppend1` 0-          msInf' = msInf `crlAppend1` (fromIntegral $ crlLen msChr')+          msChr' = msChr `crlAppend` map castCharToCChar str `crlAppend1` 0+          msInf' = msInf `crlAppend1` fromIntegral (crlLen msChr')           msMap' = Map.insert str (fromIntegral idx) msMap       put $ state {         mStrChar = msChr',@@ -168,15 +165,15 @@   let types = memberTypes m       datal = mData state       mpMap = mParamMap state-  case (Map.lookup types mpMap) of-    Just idx -> return ()+  case Map.lookup types mpMap of+    Just _ -> return ()     Nothing  -> do       let idx = crlLen datal           mpMap' = Map.insert types (fromIntegral idx) mpMap       put $ state {         mParamMap = mpMap'}-      mapM_ writeInt $ map typeId types-      mapM_ writeString $ replicate (length $ memberParams m) ""+      mapM_ (writeInt . typeId) types+      replicateM_ (length $ memberParams m) $ writeString ""  writeMethod :: Member tt -> State MOCState () writeMethod m = do@@ -193,8 +190,8 @@   state <- get   put $ state {     mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx),-    mMethodCount = mc + (mMethodCount state),-    mSignalCount = sc + (mSignalCount state),+    mMethodCount = mc + mMethodCount state,+    mSignalCount = sc + mSignalCount state,     mSigMap = maybe (mSigMap state) (\k ->       Map.insert k (fromIntegral $ mSignalCount state) (mSigMap state)) $       memberKey m,@@ -207,13 +204,13 @@   writeString $ memberName p   writeInt $ typeId $ memberType p   writeInt (pfReadable .|. pfScriptable .|.-    (if (ConstPropertyMember == memberKind p) then pfConstant else 0) .|.-    (if (isJust $ memberFunAux p) then pfWritable else 0) .|.-    (if (isJust $ memberKey p) then pfNotify else 0))+    (if ConstPropertyMember == memberKind p then pfConstant else 0) .|.+    (if isJust (memberFunAux p) then pfWritable else 0) .|.+    (if isJust (memberKey p) then pfNotify else 0))   state <- get   put $ state {     mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx),-    mPropertyCount = 1 + (mPropertyCount state),+    mPropertyCount = 1 + mPropertyCount state,     mFuncProperties = mFuncProperties state       `crlAppend1` (Just $ memberFun p) `crlAppend1` memberFunAux p   }
+ src/Graphics/QML/Internal/Objects.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE+    ScopedTypeVariables,+    TypeFamilies+  #-}++module Graphics.QML.Internal.Objects where++import Graphics.QML.Internal.BindObj+import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Types++import Control.Monad.Trans.Maybe+import Data.Tagged+import Data.Typeable+import Foreign.ForeignPtr++-- | Represents an instance of the QML class which wraps the type @tt@.+newtype ObjRef tt = ObjRef HsQMLObjectHandle++instance (Typeable tt) => Marshal (ObjRef tt) where+    type MarshalMode (ObjRef tt) c d = ModeObjBidi tt c+    marshaller = Marshaller {+        mTypeCVal_ = retag (mTypeCVal :: Tagged AnyObjRef TypeId),+        mFromCVal_ = \ptr -> do+            anyObj <- mFromCVal ptr+            MaybeT $ fromAnyObjRefIO anyObj,+        mToCVal_ = \(ObjRef hndl) ptr ->+            mToCVal (AnyObjRef hndl) ptr,+        mWithCVal_ = \(ObjRef hndl) f ->+            mWithCVal (AnyObjRef hndl) f,+        mFromJVal_ = \ptr -> do+            anyObj <- mFromJVal ptr+            MaybeT $ fromAnyObjRefIO anyObj,+        mWithJVal_ = \(ObjRef hndl) f ->+            mWithJVal (AnyObjRef hndl) f,+        mFromHndl_ =+            return . ObjRef,+        mToHndl_ = \(ObjRef hndl) ->+            return hndl}++fromObjRefIO :: ObjRef tt -> IO tt+fromObjRefIO (ObjRef hndl) = hsqmlObjectGetHsValue hndl++-- | 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.+newtype AnyObjRef = AnyObjRef HsQMLObjectHandle++instance Marshal AnyObjRef where+    type MarshalMode AnyObjRef c d = ModeObjBidi No c+    marshaller = Marshaller {+        mTypeCVal_ = Tagged tyJSValue,+        mFromCVal_ = jvalFromCVal,+        mToCVal_ = jvalToCVal,+        mWithCVal_ = jvalWithCVal,+        mFromJVal_ = \ptr -> MaybeT $ do+            hndl <- hsqmlGetObjectFromJval ptr+            return $ if isNullObjectHandle hndl+                then Nothing else Just $ AnyObjRef hndl,+        mWithJVal_ = \(AnyObjRef hndl@(HsQMLObjectHandle ptr)) f -> do+            jval <- hsqmlObjectGetJval hndl+            ret <- f jval+            touchForeignPtr ptr+            return ret,+        mFromHndl_ =+            return . AnyObjRef,+        mToHndl_ = \(AnyObjRef hndl) ->+            return hndl}++fromAnyObjRefIO :: forall tt. (Typeable tt) =>+    AnyObjRef -> IO (Maybe (ObjRef tt))+fromAnyObjRefIO (AnyObjRef hndl) = do+    info <- hsqmlObjectGetHsTyperep hndl+    let srcRep = typeOf (undefined :: tt)+        dstRep = cinfoObjType info+    return $ if srcRep == dstRep+        then Just $ ObjRef hndl+        else Nothing
src/Graphics/QML/Internal/Types.hs view
@@ -1,7 +1,6 @@ module Graphics.QML.Internal.Types where  import Data.Map (Map)-import qualified Data.Map as Map import Data.Typeable import Data.Unique import Foreign.Ptr
src/Graphics/QML/Marshal.hs view
@@ -12,9 +12,11 @@     marshaller),   ModeBidi,   ModeFrom,+  ModeTo,   ModeRetVoid,   ModeObjBidi,   ModeObjFrom,+  ModeObjTo,   Yes,   CanGetFrom,   ICanGetFrom,@@ -28,11 +30,17 @@   IGetObjType,   Marshaller, +  -- * Data Types+  Ignored (+    Ignored),+   -- * Custom Marshallers   bidiMarshallerIO,   bidiMarshaller,   fromMarshallerIO,   fromMarshaller,+  toMarshallerIO,+  toMarshaller ) where  import Graphics.QML.Internal.BindPrim@@ -41,14 +49,11 @@  import Control.Monad import Control.Monad.Trans.Maybe-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 import Foreign.C.Types-import Foreign.C.String import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable@@ -217,6 +222,26 @@         mFromHndl_ = unimplFromHndl,         mToHndl_ = unimplToHndl} +--+-- Ignored+--++-- | Represents an argument whose value is ignored.++data Ignored = Ignored++instance Marshal Ignored where+    type MarshalMode Ignored c d = ModeFrom c+    marshaller = Marshaller {+        mTypeCVal_ = Tagged tyJSValue,+        mFromCVal_ = jvalFromCVal,+        mToCVal_ = unimplToCVal,+        mWithCVal_ = unimplWithCVal,+        mFromJVal_ = \_ -> MaybeT . return $ Just Ignored,+        mWithJVal_ = unimplWithJVal,+        mFromHndl_ = unimplFromHndl,+        mToHndl_ = unimplToHndl}+ type BidiMarshaller a b = Marshaller b     (MarshalMode a ICanGetFrom ())     (MarshalMode a ICanPassTo ())@@ -279,3 +304,34 @@     forall a b. (Marshal a, CanGetFrom a ~ Yes) =>     (a -> b) -> FromMarshaller a b fromMarshaller fromFn = fromMarshallerIO (return . fromFn)++type ToMarshaller a b = Marshaller b+    No+    (MarshalMode a ICanPassTo ())+    (MarshalMode a ICanReturnTo ())+    (MarshalMode a IIsObjType ())+    (MarshalMode a IGetObjType ())++-- | Provides a "to" 'Marshaller' which allows you to define an instance of+-- 'Marshal' for your own type @b@ in terms of another marshallable type @a@.+-- Type @b@ should have a 'MarshalMode' of 'ModeObjTo' or 'ModeTo'+-- depending on whether @a@ was an object type or not.+toMarshallerIO ::+    forall a b. (Marshal a, CanPassTo a ~ Yes) =>+    (b -> IO a) -> ToMarshaller a b+toMarshallerIO toFn = Marshaller {+    mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+    mFromCVal_ = unimplFromCVal,+    mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val,+    mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,+    mFromJVal_ = unimplFromJVal,+    mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,+    mFromHndl_ = unimplFromHndl,+    mToHndl_ = \val -> mToHndl =<< toFn val}++-- | Variant of 'toMarshallerIO' where the conversion function between types+-- @a@ and @b@ does not live in the IO monad.+toMarshaller ::+    forall a b. (Marshal a, CanPassTo a ~ Yes) =>+    (b -> a) -> ToMarshaller a b+toMarshaller toFn = toMarshallerIO (return . toFn)
src/Graphics/QML/Objects.hs view
@@ -54,20 +54,17 @@   defPropertySigRW' ) where -import System.IO- import Graphics.QML.Internal.BindCore import Graphics.QML.Internal.BindObj import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.MetaObj+import Graphics.QML.Internal.Objects import Graphics.QML.Internal.Types  import Control.Concurrent.MVar-import Control.Monad.Trans.Maybe import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set import Data.Maybe import Data.Proxy@@ -76,9 +73,7 @@ import Data.IORef import Data.Unique import Foreign.Ptr-import Foreign.ForeignPtr import Foreign.Storable-import Foreign.Marshal.Alloc import Foreign.Marshal.Array import System.IO.Unsafe import Numeric@@ -87,32 +82,6 @@ -- ObjRef -- --- | Represents an instance of the QML class which wraps the type @tt@.-data ObjRef tt = ObjRef {-  objHndl :: HsQMLObjectHandle-}--instance (Typeable tt) => Marshal (ObjRef tt) where-    type MarshalMode (ObjRef tt) c d = ModeObjBidi tt c-    marshaller = Marshaller {-        mTypeCVal_ = retag (mTypeCVal :: Tagged AnyObjRef TypeId),-        mFromCVal_ = \ptr -> do-            any <- mFromCVal ptr-            MaybeT $ return $ fromAnyObjRef any,-        mToCVal_ = \obj ptr ->-            mToCVal (AnyObjRef $ objHndl obj) ptr,-        mWithCVal_ = \obj f ->-            mWithCVal (AnyObjRef $ objHndl obj) f,-        mFromJVal_ = \ptr -> do-            any <- mFromJVal ptr-            MaybeT $ return $ fromAnyObjRef any,-        mWithJVal_ = \obj f ->-            mWithJVal (AnyObjRef $ objHndl obj) f,-        mFromHndl_ = \hndl ->-            return $ ObjRef hndl,-        mToHndl_ = \obj ->-            return $ objHndl obj}- -- | Creates a QML object given a 'Class' and a Haskell value of type @tt@. newObject :: forall tt. Class tt -> tt -> IO (ObjRef tt) newObject (Class cHndl) obj =@@ -130,37 +99,6 @@ fromObjRef :: ObjRef tt -> tt fromObjRef = unsafeDupablePerformIO . fromObjRefIO -fromObjRefIO :: ObjRef tt -> IO tt-fromObjRefIO = hsqmlObjectGetHsValue . 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 c d = ModeObjBidi No c-    marshaller = Marshaller {-        mTypeCVal_ = Tagged tyJSValue,-        mFromCVal_ = jvalFromCVal,-        mToCVal_ = jvalToCVal,-        mWithCVal_ = jvalWithCVal,-        mFromJVal_ = \ptr -> MaybeT $ do-            hndl <- hsqmlGetObjectFromJval ptr-            return $ if isNullObjectHandle hndl-                then Nothing else Just $ AnyObjRef hndl,-        mWithJVal_ = \(AnyObjRef hndl@(HsQMLObjectHandle ptr)) f -> do-            jval <- hsqmlObjectGetJval hndl-            ret <- f jval-            touchForeignPtr ptr-            return ret,-        mFromHndl_ = \hndl ->-            return $ AnyObjRef hndl,-        mToHndl_ = \obj ->-            return $ anyObjHndl obj}- -- | Upcasts an 'ObjRef' into an 'AnyObjRef'. anyObjRef :: ObjRef tt -> AnyObjRef anyObjRef (ObjRef hndl) = AnyObjRef hndl@@ -170,24 +108,12 @@ fromAnyObjRef :: (Typeable tt) => AnyObjRef -> Maybe (ObjRef tt) fromAnyObjRef = unsafeDupablePerformIO . fromAnyObjRefIO -fromAnyObjRefIO :: forall tt. (Typeable tt) =>-    AnyObjRef -> IO (Maybe (ObjRef tt))-fromAnyObjRefIO (AnyObjRef hndl) = do-    info <- hsqmlObjectGetHsTyperep hndl-    let srcRep = typeOf (undefined :: tt)-        dstRep = cinfoObjType info-    if srcRep == dstRep-        then return $ Just $ ObjRef hndl-        else return Nothing- -- -- Class --  -- | Represents a QML class which wraps the type @tt@.-data Class tt = Class {-  classHndl :: HsQMLClassHandle-}+newtype Class tt = Class HsQMLClassHandle  -- | Creates a new QML class for the type @tt@. newClass :: forall tt. (Typeable tt) => [Member tt] -> IO (Class tt)@@ -230,7 +156,7 @@             (\_ _ -> return ())             Nothing             (Just k)-    in map (uncurry impMember) $ zip [0..] impKeys+    in map (uncurry impMember) $ zip [(0::Int)..] impKeys  -- -- Default Class@@ -328,7 +254,7 @@ newtype VoidIO = VoidIO {runVoidIO :: (IO ())}  instance MethodSuffix VoidIO where-    mkMethodFunc _ f pv = errIO $ runVoidIO f+    mkMethodFunc _ f _ = errIO $ runVoidIO f     mkMethodTypes = Tagged $ MethodTypeInfo [] tyVoid  class IsVoidIO a
+ src/Graphics/QML/Objects/Weak.hs view
@@ -0,0 +1,120 @@+-- | Facilities for working with weak references, finalisers, and factory+-- pools.+module Graphics.QML.Objects.Weak (+    -- * Weak Object References+    WeakObjRef,+    toWeakObjRef,+    fromWeakObjRef,++    -- * Object Finalisers+    ObjFinaliser,+    newObjFinaliser,+    addObjFinaliser,++    -- * Factory Pools+    FactoryPool,+    newFactoryPool,+    getPoolObject+) where++import Graphics.QML.Internal.BindObj+import Graphics.QML.Internal.Objects++import Control.Concurrent.MVar+import qualified Data.Map as Map+import Data.Map (Map)++-- | Represents a weak reference to a QML object which wraps the type @tt@.+--+-- Unlike ordinary strong references, a weak reference does not prevent the+-- QML garbage collector from collecting the underlying object. Weak references+-- can be used to monitor the life cycles of QML objects.+newtype WeakObjRef tt = WeakObjRef HsQMLObjectHandle++-- | Converts a strong 'ObjRef' into a 'WeakObjRef'. +toWeakObjRef :: ObjRef tt -> IO (WeakObjRef tt)+toWeakObjRef (ObjRef hndl) = do+    hndl' <- copyObjectHandle hndl True+    return $ WeakObjRef hndl'++-- | Converts a 'WeakObjRef' into a strong 'ObjRef'.+--+-- If the underlying QML object has already been collected then the resulting+-- 'ObjRef' can be used to reincarnate it.+fromWeakObjRef :: WeakObjRef tt -> IO (ObjRef tt)+fromWeakObjRef (WeakObjRef hndl) = do+    hndl' <- copyObjectHandle hndl False+    return $ ObjRef hndl'++-- | Represents an object finaliser function for QML objects which wrap the+-- type @tt@.+data ObjFinaliser tt = ObjFinaliser HsQMLObjFinaliserHandle++-- | Create a new object finaliser from a finaliser function.+--+-- Note that at the time the finaliser is called the runtime will have already+-- comitted to collecting the underlying QML object. The 'ObjRef' passed into+-- the finaliser can be used to reincarnate the object, but this QML object+-- will have a distinct identity to the original.+newObjFinaliser :: (ObjRef tt -> IO ()) -> IO (ObjFinaliser tt)+newObjFinaliser f = do+    fPtr <- marshalObjFinaliser $ \hPtr -> do+        hndl <- newObjectHandle hPtr+        f $ ObjRef hndl+    final <- hsqmlCreateObjFinaliser fPtr+    return $ ObjFinaliser final++-- | Adds an object finaliser to an QML object.+--+-- The finaliser will be called no more than once for each time it was added to+-- an object. The timing of finaliser execution is subject to the combined+-- behaviour of the Haskell and QML garbage collectors. All outstanding+-- finalisers will be run when the QML engine is terminated provided that the+-- program does not prematurely exit.+addObjFinaliser :: ObjFinaliser tt -> ObjRef tt -> IO ()+addObjFinaliser (ObjFinaliser final) (ObjRef hndl) =+    hsqmlObjectAddFinaliser hndl final++-- | Represents an object factory which maintains a one-to-one mapping between+-- values of type @tt@ and QML object instances.+--+-- 'ObjRef's manufactured by the pool are cached using the wrapped type @tt@ as+-- the lookup key in an ordered map. The pool uses weak references to+-- automatically purge objects which no longer have any strong references+-- leading to them from either Haskell or QML code.++-- Hence, the pool guarantees that if QML code is using a pool object (e.g. as+-- a source for data binding) then the same object instance can be obtained+-- again from the pool. Conversely, if an object instance is no longer being+-- used then pool will not prevent it from being garbage collected.+data FactoryPool tt = FactoryPool {+    factory_   :: tt -> IO (ObjRef tt),+    pool_      :: MVar (Map tt (WeakObjRef tt)),+    finaliser_ :: ObjFinaliser tt+}++-- | Creates a new 'FactoryPool' using the supplied factory function.+newFactoryPool :: (Ord tt) =>+    (tt -> IO (ObjRef tt)) -> IO (FactoryPool tt)+newFactoryPool factory = do+    pool <- newMVar Map.empty+    finaliser <- newObjFinaliser $ \obj -> do+        value <- fromObjRefIO obj+        modifyMVar_ pool (return . Map.delete value)+    return $ FactoryPool factory pool finaliser++-- | Return the pool's canonical QML object for a value of @tt@, either by+-- creating it or looking it up in the pool's cache of objects.+getPoolObject :: (Ord tt) =>+    FactoryPool tt -> tt -> IO (ObjRef tt)+getPoolObject (FactoryPool factory pool finaliser) value =+    modifyMVar pool $ \pmap ->+        case Map.lookup value pmap of+            Just wkObj -> do+                obj <- fromWeakObjRef wkObj+                return (pmap, obj)+            Nothing  -> do+                obj <- factory value+                addObjFinaliser finaliser obj+                wkObj <- toWeakObjRef obj+                return (Map.insert value wkObj pmap, obj)