hsqml 0.3.2.1 → 0.3.3.0
raw patch · 24 files changed
+661/−72 lines, 24 filessetup-changed
Files
- CHANGELOG +12/−0
- LICENSE +1/−1
- Setup.hs +53/−17
- SetupNoTH.hs +20/−6
- cbits/Canvas.cpp +283/−2
- cbits/Canvas.h +92/−0
- cbits/Engine.cpp +14/−0
- cbits/Engine.h +2/−0
- cbits/Manager.cpp +2/−0
- cbits/Object.cpp +1/−0
- cbits/hsqml.h +3/−1
- hsqml.cabal +4/−3
- src/Graphics/QML/Canvas.hs +32/−7
- src/Graphics/QML/Engine.hs +31/−5
- src/Graphics/QML/Internal/BindCanvas.chs +2/−1
- src/Graphics/QML/Internal/BindCore.chs +2/−0
- src/Graphics/QML/Internal/BindPrim.chs +6/−2
- src/Graphics/QML/Internal/Marshal.hs +2/−2
- src/Graphics/QML/Internal/MetaObj.hs +3/−3
- src/Graphics/QML/Internal/Objects.hs +3/−3
- src/Graphics/QML/Internal/Types.hs +2/−0
- src/Graphics/QML/Marshal.hs +15/−15
- src/Graphics/QML/Objects.hs +17/−4
- src/Graphics/QML/Objects/ParamNames.hs +59/−0
CHANGELOG view
@@ -1,5 +1,17 @@ HsQML - Release History +release-0.3.3.0 - 2015.01.20++ * Added support for Cabal 1.22 API.+ * Added facility for controlling the OpenGL context.+ * Added defSignal variant with ability to set parameter names.+ * Added option for setting the module and plugin search paths.+ * Changed Setup script to set QT_SELECT (base >= 4.7).+ * Fixed crash resizing canvas in Inline mode.+ * Fixed leaking stable pointers when objects are collected.+ * Fixed Canvas delegate marshaller to fail on invalid values.+ * Fixed discrepancy between kinds of type conversion.+ release-0.3.2.1 - 2014.11.29 * Added function to shutdown the Qt framework.
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c)2010-2014, Robin KAY+Copyright (c)2010-2015, Robin KAY All rights reserved.
Setup.hs view
@@ -7,6 +7,7 @@ import Data.List import Data.Maybe import Distribution.Simple+import Distribution.Simple.Compiler import Distribution.Simple.BuildPaths import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program@@ -20,41 +21,66 @@ import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription import Language.Haskell.TH+import System.Environment+import qualified System.Info as Info import System.FilePath --- Use Template Haskell to support both the pre- and post-1.18 Cabal API+-- Use Template Haskell to support different versions of the Cabal API $(let- newCabalAPI = cabalVersion >= Version [1,17,0] []+ post4700BaseAPI = Info.compilerVersion >= Version [7,7] []+ post118CabalAPI = cabalVersion >= Version [1,17,0] []+ post122CabalAPI = cabalVersion >= Version [1,21,0] [] vnameE = VarE . mkName vnameP = VarP . mkName cnameE = ConE . mkName app2E f x y = AppE (AppE f x) y app3E f x y z = AppE (app2E f x y) z+ app4E f x y z u = AppE (app3E f x y z) u+ app5E f x y z u v = AppE (app4E f x y z u) v nothingE = cnameE "Nothing" falseE = cnameE "False"+ -- 'setEnv' function was added in base 4.7.0.0+ setEnvShim = if post4700BaseAPI+ then vnameE "setEnv"+ else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "()") -- 'LocalBuildInfo' record changed fields in Cabal 1.18- extractCLBI = if newCabalAPI+ extractCLBI = if post118CabalAPI then app2E (vnameE "getComponentLocalBuildInfo") (vnameE "x") (cnameE "CLibName") else AppE (vnameE "fromJust") $ AppE (vnameE "libraryConfig") (vnameE "x") -- 'programFindLocation' field changed signature in Cabal 1.18- adaptFindLoc = if newCabalAPI+ adaptFindLoc = if post118CabalAPI then LamE [vnameP "f", vnameP "x", WildP] $ AppE (vnameE "f") (vnameE "x") else vnameE "id" -- 'rawSystemStdInOut' function changed signature in Cabal 1.18- rawSystemStdErr = if newCabalAPI- then AppE (app3E (app3E (vnameE "rawSystemStdInOut")+ rawSystemStdErr = if post118CabalAPI+ then app4E (app3E (vnameE "rawSystemStdInOut") (vnameE "v") (vnameE "p") (vnameE "a"))- nothingE nothingE nothingE) falseE - else app2E (app3E (vnameE "rawSystemStdInOut")- (vnameE "v") (vnameE "p") (vnameE "a")) nothingE falseE+ nothingE nothingE nothingE falseE + else app5E (vnameE "rawSystemStdInOut")+ (vnameE "v") (vnameE "p") (vnameE "a") nothingE falseE -- 'programPostConf' field changed signature in Cabal 1.18- noPostConf = if newCabalAPI+ noPostConf = if post118CabalAPI then LamE [WildP, vnameP "c"] $ AppE (vnameE "return") (vnameE "c") else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "[]")+ -- 'generateRegistrationInfo' function changed signature in Cabal 1.22+ genRegInfo = if post122CabalAPI+ then LamE [vnameP "pdb"] $ app2E (vnameE ">>=")+ (AppE (vnameE "absolutePackageDBPaths") (vnameE "pdb")) $+ LamE [vnameP "apdb"] $+ app5E (app4E (vnameE "generateRegistrationInfo")+ (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi"))+ (vnameE "clbi") (vnameE "inp")+ (AppE (vnameE "relocatable") (vnameE "lbi")) (vnameE "dir")+ (AppE (vnameE "registrationPackageDB") (vnameE "apdb"))+ else LamE [WildP] $ app3E (app4E (vnameE "generateRegistrationInfo")+ (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi"))+ (vnameE "clbi") (vnameE "inp") (vnameE "dir") in return [+ FunD (mkName "setEnvShim") [+ Clause [] (NormalB setEnvShim) []], FunD (mkName "extractCLBI") [ Clause [vnameP "x"] (NormalB extractCLBI) []], FunD (mkName "adaptFindLoc") [@@ -63,13 +89,24 @@ Clause [vnameP "v", vnameP "p", vnameP "a"] ( NormalB rawSystemStdErr) []], FunD (mkName "noPostConf") [- Clause [] (NormalB noPostConf) []]])+ Clause [] (NormalB noPostConf) []],+ FunD (mkName "genRegInfo") [+ Clause [vnameP "verb", vnameP "pkg", vnameP "lib", vnameP "lbi",+ vnameP "clbi", vnameP "inp", vnameP "dir"] (+ NormalB genRegInfo) []]]) main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- confHook = confWithQt, buildHook = buildWithQt,- copyHook = copyWithQt, instHook = instWithQt,- regHook = regWithQt}+main = do+ -- If system uses qtchooser(1) then encourage it to choose Qt 5+ env <- getEnvironment+ case lookup "QT_SELECT" env of+ Nothing -> setEnvShim "QT_SELECT" "5"+ _ -> return ()+ -- Chain standard setup+ defaultMainWithHooks simpleUserHooks {+ confHook = confWithQt, buildHook = buildWithQt,+ copyHook = copyWithQt, instHook = instWithQt,+ regHook = regWithQt} getCustomStr :: String -> PackageDescription -> String getCustomStr name pkgDesc =@@ -237,8 +274,7 @@ dist = fromFlag $ regDistPref flags pkgDb = withPackageDB lbi clbi = extractCLBI lbi- instPkgInfo <- generateRegistrationInfo- verb pkg lib lbi clbi inplace dist+ instPkgInfo <- genRegInfo verb pkg lib lbi clbi inplace dist pkgDb let instPkgInfo' = instPkgInfo { -- Add extra library for GHCi workaround I.extraGHCiLibraries =
SetupNoTH.hs view
@@ -1,5 +1,6 @@ #!/usr/bin/runhaskell -- This is an alternate version of Setup.hs which doesn't use Template Haskell.+-- It's appropriate for Cabal >= 1.18 && < 1.22 module Main where import Control.Monad@@ -19,8 +20,12 @@ import qualified Distribution.InstalledPackageInfo as I import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription+import System.Environment import System.FilePath +-- 'setEnv' function was added in base 4.7.0.0+setEnvShim :: String -> String -> IO ()+setEnvShim _ _ = return () -- 'LocalBuildInfo' record changed fields in Cabal 1.18 extractCLBI :: LocalBuildInfo -> ComponentLocalBuildInfo extractCLBI x = getComponentLocalBuildInfo x CLibName@@ -31,12 +36,22 @@ rawSystemStdErr v p a = rawSystemStdInOut v p a Nothing Nothing Nothing False -- 'programPostConf' field changed signature in Cabal 1.18 noPostConf _ c = return c+-- 'generateRegistrationInfo' function will change signature in Cabal 1.22+genRegInfo verb pkg lib lbi clbi inp dir _ =+ generateRegistrationInfo verb pkg lib lbi clbi inp dir main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- confHook = confWithQt, buildHook = buildWithQt,- copyHook = copyWithQt, instHook = instWithQt,- regHook = regWithQt}+main = do+ -- If system uses qtchooser(1) then encourage it to choose Qt 5+ env <- getEnvironment+ case lookup "QT_SELECT" env of+ Nothing -> setEnvShim "QT_SELECT" "5"+ _ -> return ()+ -- Chain standard setup+ defaultMainWithHooks simpleUserHooks {+ confHook = confWithQt, buildHook = buildWithQt,+ copyHook = copyWithQt, instHook = instWithQt,+ regHook = regWithQt} getCustomStr :: String -> PackageDescription -> String getCustomStr name pkgDesc =@@ -204,8 +219,7 @@ dist = fromFlag $ regDistPref flags pkgDb = withPackageDB lbi clbi = extractCLBI lbi- instPkgInfo <- generateRegistrationInfo- verb pkg lib lbi clbi inplace dist+ instPkgInfo <- genRegInfo verb pkg lib lbi clbi inplace dist pkgDb let instPkgInfo' = instPkgInfo { -- Add extra library for GHCi workaround I.extraGHCiLibraries =
cbits/Canvas.cpp view
@@ -44,6 +44,11 @@ mImpl = new HsQMLGLDelegateImpl(makeContextCb); } +bool HsQMLGLDelegate::isValid()+{+ return mImpl;+}+ HsQMLGLDelegate::CallbacksRef HsQMLGLDelegate::makeCallbacks() { CallbacksRef dataPtr;@@ -397,8 +402,8 @@ if (!n) { n = new QSGSimpleTextureNode(); }- n->setRect(0, 0, width(), height()); n->setTexture(texture);+ n->setRect(0, 0, width(), height()); return n; } @@ -541,6 +546,281 @@ setStatus(status, true); } +HsQMLContextControl::HsQMLContextControl(QQuickItem* parent)+ : QQuickItem(parent)+ , mWindow(NULL)+ , mMajorVersion(-1)+ , mMinorVersion(-1)+ , mContextType(TypeUnset)+ , mContextProfile(ProfileUnset)+ , mDeprecatedFunctions(false)+ , mDeprecatedFunctionsSet(false)+ , mDepthBufferSize(0)+ , mStencilBufferSize(0)+ , mWhen(true)+ , mDefer(false)+ , mPending(false)+{+ QObject::connect(+ this, SIGNAL(windowChanged(QQuickWindow*)),+ this, SLOT(doWindowChanged(QQuickWindow*)));+}++HsQMLContextControl::~HsQMLContextControl()+{+}++int HsQMLContextControl::majorVersion()+{+ return mCurrent.majorVersion();+}++void HsQMLContextControl::setMajorVersion(int major)+{+ bool change = mMajorVersion != major;+ mMajorVersion = major;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetMajorVersion()+{+ setMajorVersion(-1);+}++int HsQMLContextControl::minorVersion()+{+ return mCurrent.minorVersion();+}++void HsQMLContextControl::setMinorVersion(int minor)+{+ bool change = mMinorVersion != minor;+ mMinorVersion = minor;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetMinorVersion()+{+ setMinorVersion(-1);+}++HsQMLContextControl::ContextType HsQMLContextControl::contextType()+{+ return static_cast<ContextType>(mCurrent.renderableType());+}++void HsQMLContextControl::setContextType(ContextType type)+{+ bool change = mContextType != type;+ mContextType = type;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetContextType()+{+ setContextType(TypeUnset);+}++HsQMLContextControl::ContextProfile HsQMLContextControl::contextProfile()+{+ return static_cast<ContextProfile>(mCurrent.profile());+}++void HsQMLContextControl::setContextProfile(ContextProfile profile)+{+ bool change = mContextProfile != profile;+ mContextProfile = profile;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetContextProfile()+{+ setContextProfile(ProfileUnset);+}++bool HsQMLContextControl::deprecatedFunctions()+{+ return mCurrent.testOption(QSurfaceFormat::DeprecatedFunctions);+}++void HsQMLContextControl::setDeprecatedFunctions(bool df, bool set)+{+ bool change = (mDeprecatedFunctionsSet != set) ||+ (mDeprecatedFunctionsSet && (mDeprecatedFunctions != df));+ mDeprecatedFunctions = df;+ mDeprecatedFunctionsSet = set;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetDeprecatedFunctions()+{+ setDeprecatedFunctions(false, false);+}++int HsQMLContextControl::depthBufferSize()+{+ return mCurrent.depthBufferSize();+}++void HsQMLContextControl::setDepthBufferSize(int size)+{+ bool change = mDepthBufferSize != size;+ mDepthBufferSize = size;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetDepthBufferSize()+{+ setDepthBufferSize(0);+}++int HsQMLContextControl::stencilBufferSize()+{+ return mCurrent.stencilBufferSize();+}++void HsQMLContextControl::setStencilBufferSize(int size)+{+ bool change = mStencilBufferSize != size;+ mStencilBufferSize = size;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetStencilBufferSize()+{+ setStencilBufferSize(0);+}++bool HsQMLContextControl::when()+{+ return mWhen;+}++void HsQMLContextControl::setWhen(bool when)+{+ mWhen = when;+ if (mPending && !mDefer && mWhen) {+ controlContext();+ }+}++void HsQMLContextControl::classBegin()+{+ mDefer = true;+}++void HsQMLContextControl::componentComplete()+{+ mDefer = false;+ if (mPending && mWhen) {+ controlContext();+ }+}++void HsQMLContextControl::doWindowChanged(QQuickWindow* win)+{+ if (mWindow) {+ QObject::disconnect(mWindow, 0, this, 0);+ }+ mWindow = win;+ if (mWindow) {+ QObject::connect(+ mWindow, SIGNAL(sceneGraphInitialized()),+ this, SLOT(doSceneGraphInit()));+ mOriginal = mWindow->requestedFormat();+ mCurrent = mWindow->openglContext() ?+ mWindow->openglContext()->format() : mWindow->format();+ }+ else {+ mOriginal = QSurfaceFormat();+ mCurrent = QSurfaceFormat();+ }+ contextChanged();++ if ((mMajorVersion >=0) || (mMinorVersion >= 0) ||+ (mContextType != TypeUnset) || (mContextProfile != ProfileUnset) ||+ !mDeprecatedFunctionsSet) {+ controlContext();+ }+}++void HsQMLContextControl::doSceneGraphInit()+{+ mCurrent = mWindow->openglContext()->format();+ contextChanged();+}++void HsQMLContextControl::controlContext()+{+ // Do nothing if no window+ if (!mWindow) {+ return;+ }++ // Do nothing if changes are being deferred+ if (mDefer || !mWhen) {+ mPending = true;+ return;+ }+ mPending = false;++ QSurfaceFormat fmt = mOriginal;+ if (mMajorVersion >= 0) {+ fmt.setMajorVersion(mMajorVersion);+ }+ if (mMinorVersion >= 0) {+ fmt.setMinorVersion(mMinorVersion);+ }+ if (mContextType >= 0) {+ fmt.setRenderableType(static_cast<QSurfaceFormat::RenderableType>(+ mContextType));+ }+ if (mContextProfile >= 0) {+ fmt.setProfile(static_cast<QSurfaceFormat::OpenGLContextProfile>(+ mContextProfile));+ }+ if (mDeprecatedFunctionsSet) {+#if QT_VERSION >= 0x050300+ fmt.setOption(QSurfaceFormat::DeprecatedFunctions,+ mDeprecatedFunctions);+#else+ if (mDeprecatedFunctions) {+ fmt.setOption(QSurfaceFormat::DeprecatedFunctions);+ }+#endif+ }+ fmt.setDepthBufferSize(qMax(fmt.depthBufferSize(), mDepthBufferSize));+ fmt.setStencilBufferSize(qMax(fmt.stencilBufferSize(), mStencilBufferSize));+ if (fmt == mWindow->requestedFormat()) {+ return;+ }+ mWindow->setFormat(fmt);++ // Recreate OpenGL context+ mWindow->setPersistentOpenGLContext(false);+ mWindow->setPersistentSceneGraph(false);+ bool visible = mWindow->isVisible();+ mWindow->destroy();+ mWindow->releaseResources();+ mWindow->setVisible(visible);+ mWindow->setPersistentOpenGLContext(true);+ mWindow->setPersistentSceneGraph(true);+}+ HsQMLGLDelegateHandle* hsqml_create_gldelegate() { return reinterpret_cast<HsQMLGLDelegateHandle*>(new HsQMLGLDelegate());@@ -570,7 +850,7 @@ gManager->activeEngine()->declEngine()->toScriptValue(*delegate)); } -void hsqml_gldelegate_from_jval(+int hsqml_gldelegate_from_jval( HsQMLGLDelegateHandle* hndl, HsQMLJValHandle* jhndl) {@@ -578,4 +858,5 @@ QJSValue* value = reinterpret_cast<QJSValue*>(jhndl); *delegate = gManager->activeEngine()->declEngine()-> fromScriptValue<HsQMLGLDelegate>(*value); + return delegate->isValid(); }
cbits/Canvas.h view
@@ -47,6 +47,7 @@ HsQMLGLDelegate(); ~HsQMLGLDelegate(); void setup(HsQMLGLMakeCallbacksCb);+ bool isValid(); typedef QExplicitlySharedDataPointer<HsQMLGLCallbacks> CallbacksRef; CallbacksRef makeCallbacks(); @@ -198,6 +199,97 @@ qreal mCanvasHeight; QScopedPointer<QOpenGLFramebufferObject> mFBO; QScopedPointer<QSGTexture> mTexture;+};++class HsQMLContextControl : public QQuickItem+{+ Q_OBJECT+ Q_ENUMS(ContextType)+ Q_ENUMS(ContextProfile)+ Q_PROPERTY(int majorVersion READ majorVersion WRITE setMajorVersion+ RESET unsetMajorVersion NOTIFY contextChanged);+ Q_PROPERTY(int minorVersion READ minorVersion WRITE setMinorVersion+ RESET unsetMinorVersion NOTIFY contextChanged);+ Q_PROPERTY(ContextType contextType READ contextType WRITE setContextType+ RESET unsetContextType NOTIFY contextChanged);+ Q_PROPERTY(ContextProfile contextProfile READ contextProfile+ WRITE setContextProfile RESET unsetContextProfile+ NOTIFY contextChanged);+ Q_PROPERTY(bool deprecatedFunctions READ deprecatedFunctions+ WRITE setDeprecatedFunctions+ RESET unsetDeprecatedFunctions NOTIFY contextChanged);+ Q_PROPERTY(int depthBufferSize READ depthBufferSize+ WRITE setDepthBufferSize+ RESET unsetDepthBufferSize NOTIFY contextChanged);+ Q_PROPERTY(int stencilBufferSize READ stencilBufferSize+ WRITE setStencilBufferSize+ RESET unsetStencilBufferSize NOTIFY contextChanged);+ Q_PROPERTY(bool when READ when WRITE setWhen);++public:+ enum ContextType {+ TypeUnset = -1,+ UnknownType = QSurfaceFormat::DefaultRenderableType,+ OpenGL = QSurfaceFormat::OpenGL,+ OpenGLES = QSurfaceFormat::OpenGLES+ };+ enum ContextProfile {+ ProfileUnset = -1,+ NoProfile = QSurfaceFormat::NoProfile,+ CoreProfile = QSurfaceFormat::CoreProfile,+ CompatibilityProfile = QSurfaceFormat::CompatibilityProfile+ };++ HsQMLContextControl(QQuickItem* = NULL);+ ~HsQMLContextControl();++ Q_SIGNAL void contextChanged();+ int majorVersion();+ void setMajorVersion(int);+ void unsetMajorVersion();+ int minorVersion();+ void setMinorVersion(int);+ void unsetMinorVersion();+ ContextType contextType();+ void setContextType(ContextType);+ void unsetContextType();+ ContextProfile contextProfile();+ void setContextProfile(ContextProfile);+ void unsetContextProfile();+ bool deprecatedFunctions();+ void setDeprecatedFunctions(bool, bool = true);+ void unsetDeprecatedFunctions();+ int depthBufferSize();+ void setDepthBufferSize(int);+ void unsetDepthBufferSize();+ int stencilBufferSize();+ void setStencilBufferSize(int);+ void unsetStencilBufferSize();+ bool when();+ void setWhen(bool);++private:+ Q_DISABLE_COPY(HsQMLContextControl);++ Q_SLOT void doWindowChanged(QQuickWindow*);+ Q_SLOT void doSceneGraphInit();+ void classBegin();+ void componentComplete();+ void controlContext();+ QQuickWindow* mWindow;+ QSurfaceFormat mOriginal;+ QSurfaceFormat mCurrent;+ int mMajorVersion;+ int mMinorVersion;+ ContextType mContextType;+ ContextProfile mContextProfile;+ bool mDeprecatedFunctions;+ bool mDeprecatedFunctionsSet;+ int mDepthBufferSize;+ int mStencilBufferSize;+ bool mWhen;+ bool mDefer;+ bool mPending; }; #endif //HSQML_CANVAS_H
cbits/Engine.cpp view
@@ -24,6 +24,12 @@ mObjects << ctx; } + // Engine settings+ mEngine.setImportPathList(+ QStringList(config.importPaths) << mEngine.importPathList());+ mEngine.setPluginPathList(+ QStringList(config.pluginPaths) << mEngine.pluginPathList());+ // Load document mComponent.loadUrl(QUrl(config.initialURL)); }@@ -95,11 +101,19 @@ extern "C" void hsqml_create_engine( HsQMLObjectHandle* contextObject, HsQMLStringHandle* initialURL,+ HsQMLStringHandle** importPaths,+ HsQMLStringHandle** pluginPaths, HsQMLTrivialCb stopCb) { HsQMLEngineConfig config; config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject); config.initialURL = *reinterpret_cast<QString*>(initialURL);+ for (QString** p = reinterpret_cast<QString**>(importPaths); *p; p++) {+ config.importPaths.push_back(**p);+ }+ for (QString** p = reinterpret_cast<QString**>(pluginPaths); *p; p++) {+ config.pluginPaths.push_back(**p);+ } config.stopCb = stopCb; Q_ASSERT (gManager);
cbits/Engine.h view
@@ -22,6 +22,8 @@ HsQMLObjectProxy* contextObject; QString initialURL;+ QStringList importPaths;+ QStringList pluginPaths; HsQMLTrivialCb stopCb; };
cbits/Manager.cpp view
@@ -368,6 +368,8 @@ // Register custom types qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig"); qmlRegisterType<HsQMLCanvas>("HsQML.Canvas", 1, 0, "HaskellCanvas");+ qmlRegisterType<HsQMLContextControl>(+ "HsQML.Canvas", 1, 0, "OpenGLContextControl"); } HsQMLManagerApp::~HsQMLManagerApp()
cbits/Object.cpp view
@@ -39,6 +39,7 @@ { mKlass->deref(HsQMLClass::ObjProxy); gManager->updateCounter(HsQMLManager::ObjectCount, -1);+ gManager->freeStable(mHaskell); } HsStablePtr HsQMLObjectProxy::haskell() const
cbits/hsqml.h view
@@ -195,6 +195,8 @@ extern void hsqml_create_engine( HsQMLObjectHandle*, HsQMLStringHandle*,+ HsQMLStringHandle**,+ HsQMLStringHandle**, HsQMLTrivialCb stopCb); /* Canvas */@@ -235,7 +237,7 @@ HsQMLGLDelegateHandle*, HsQMLJValHandle*); -extern void hsqml_gldelegate_from_jval(+extern int hsqml_gldelegate_from_jval( HsQMLGLDelegateHandle*, HsQMLJValHandle*);
hsqml.cabal view
@@ -1,16 +1,16 @@ Name: hsqml-Version: 0.3.2.1+Version: 0.3.3.0 Cabal-version: >= 1.14 Build-type: Custom License: BSD3 License-file: LICENSE-Copyright: (c) 2010-2014 Robin KAY+Copyright: (c) 2010-2015 Robin KAY Author: Robin KAY Maintainer: komadori@gekkou.co.uk Stability: experimental Homepage: http://www.gekkou.co.uk/software/hsqml/ Bug-reports: http://trac.gekkou.co.uk/hsqml/-Category: Graphics+Category: Graphics, GUI Synopsis: Haskell binding for Qt Quick Extra-source-files: README CHANGELOG SetupNoTH.hs@@ -56,6 +56,7 @@ Graphics.QML.Engine Graphics.QML.Marshal Graphics.QML.Objects+ Graphics.QML.Objects.ParamNames Graphics.QML.Objects.Weak Other-modules: Graphics.QML.Internal.BindPrim
src/Graphics/QML/Canvas.hs view
@@ -7,9 +7,9 @@ {-| 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:+QML scene. This item can be imported from the @HsQML.Canvas 1.0@ module using+an @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:@@ -30,6 +30,30 @@ [@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).++The @HsQML.Canvas 1.0@ module also contains another type of item called+@OpenGLConextControl@ which can be used to configure the OpenGL context used by+your windows. When placed inside a QML window, it has several properties which+when read return the current state of that window's OpenGL context, and when+written to cause the window's context to be reconfigured with a request for the+supplied setting. Note that as reconfiguring the context may cause a visible+window to dis- and re-appear, it's recommended to supply the desired settings+at startup or otherwise before the corresponding window is made visible.+Available properties are as below:++[@majorVersion@] Major component of the OpenGL version.+[@minorVersion@] Minor component of the OpenGL version.+[@contextType@] The type of OpenGL context. One of:+@OpenGLContextControl.UnknownType@, @OpenGLContextControl.OpenGL@, or+@OpenGLContextControl.OpenGLES@.+[@contextProfile@] The OpenGL context's profile. One of:+@OpenGLContextControl.NoProfile@, @OpenGLContextControl.CoreProfile@, or+@OpenGLContextControl.CompatibilityProfile@.+[@deprecatedFunctions@] True if deprecated functions are available.+[@depthBufferSize@] Depth buffer size in bits.+[@stencilBufferSize@] Stencil buffer size in bits.+[@when@] Any changes to the OpenGL context while this property is set to false+will be deferred until it is true again. The default value is true. -} module Graphics.QML.Canvas ( OpenGLDelegate,@@ -53,6 +77,7 @@ import Graphics.QML.Internal.BindCanvas import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Types import Graphics.QML.Marshal import Data.IORef@@ -72,10 +97,10 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = jvalToCVal, mWithCVal_ = jvalWithCVal,- mFromJVal_ = \ptr -> MaybeT $ do+ mFromJVal_ = \_ ptr -> MaybeT $ do hndl <- hsqmlCreateGldelegate- hsqmlGldelegateFromJval hndl ptr- return $ Just $ OpenGLDelegate hndl,+ fromJVal Weak (hsqmlGldelegateFromJval hndl)+ (const . return $ OpenGLDelegate hndl) ptr, mWithJVal_ = \(OpenGLDelegate hndl) f -> withJVal (flip hsqmlGldelegateToJval) hndl f, mFromHndl_ = unimplFromHndl,@@ -136,7 +161,7 @@ iVal <- readIORef iRef cleanupFn $ fromJust iVal syncCb ptr = do- mVal <- runMaybeT $ mFromJVal ptr+ mVal <- runMaybeT $ mFromJVal Strong ptr writeIORef mRef mVal return $ if isJust mVal then 1 else 0 paintCb mPtr w h = do
src/Graphics/QML/Engine.hs view
@@ -10,7 +10,9 @@ EngineConfig( EngineConfig, initialDocument,- contextObject),+ contextObject,+ importPaths,+ pluginPaths), defaultEngineConfig, Engine, runEngine,@@ -47,15 +49,21 @@ import Data.List import Data.Traversable import Data.Typeable+import Foreign.Marshal.Array import Foreign.Ptr-import System.FilePath (isAbsolute, splitDirectories, pathSeparators)+import Foreign.Storable+import System.FilePath (FilePath, isAbsolute, splitDirectories, pathSeparators) -- | Holds parameters for configuring a QML runtime engine. data EngineConfig = EngineConfig { -- | Path to the first QML document to be loaded. initialDocument :: DocumentPath, -- | Context 'Object' made available to QML script code.- contextObject :: Maybe AnyObjRef+ contextObject :: Maybe AnyObjRef,+ -- | Additional search paths for QML modules+ importPaths :: [FilePath],+ -- | Additional search paths for QML native plugins+ pluginPaths :: [FilePath] } -- | Default engine configuration. Loads @\"main.qml\"@ from the current@@ -63,7 +71,9 @@ defaultEngineConfig :: EngineConfig defaultEngineConfig = EngineConfig { initialDocument = DocumentPath "main.qml",- contextObject = Nothing+ contextObject = Nothing,+ importPaths = [],+ pluginPaths = [] } -- | Represents a QML engine.@@ -74,10 +84,26 @@ hsqmlInit let obj = contextObject config DocumentPath res = initialDocument config+ impPaths = importPaths config+ plugPaths = pluginPaths config hndl <- sequenceA $ fmap mToHndl obj mWithCVal (T.pack res) $ \resPtr ->- hsqmlCreateEngine hndl (HsQMLStringHandle $ castPtr resPtr) stopCb+ withManyArray0 mWithCVal (map T.pack impPaths) nullPtr $ \impPtr ->+ withManyArray0 mWithCVal (map T.pack plugPaths) nullPtr $ \plugPtr ->+ hsqmlCreateEngine hndl (HsQMLStringHandle $ castPtr resPtr)+ (castPtr impPtr) (castPtr plugPtr) stopCb return Engine++withMany :: (a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c+withMany func as cont =+ let rec (a:as') bs = func a (\b -> rec as' (bs . (b:)))+ rec [] bs = cont $ bs []+ in rec as id++withManyArray0 :: Storable b =>+ (a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c+withManyArray0 func as term cont =+ withMany func as $ \ptrs -> withArray0 term ptrs cont -- | Starts a new QML engine using the supplied configuration and blocks until -- the engine has terminated.
src/Graphics/QML/Internal/BindCanvas.chs view
@@ -7,6 +7,7 @@ {#import Graphics.QML.Internal.BindPrim #} import Foreign.C.Types+import Foreign.Marshal.Utils import Foreign.Ptr import Foreign.ForeignPtr.Safe import Foreign.Storable@@ -85,4 +86,4 @@ {#fun unsafe hsqml_gldelegate_from_jval as ^ {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle', id `HsQMLJValHandle'} ->- `()' #}+ `Bool' toBool #}
src/Graphics/QML/Internal/BindCore.chs view
@@ -70,6 +70,8 @@ {#fun hsqml_create_engine as ^ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle', id `HsQMLStringHandle',+ id `Ptr HsQMLStringHandle',+ id `Ptr HsQMLStringHandle', withTrivialCb* `TrivialCb'} -> `()' #}
src/Graphics/QML/Internal/BindPrim.chs view
@@ -4,6 +4,8 @@ module Graphics.QML.Internal.BindPrim where +import Graphics.QML.Internal.Types+ import Foreign.C.Types import Foreign.Marshal.Alloc import Foreign.Marshal.Utils@@ -139,9 +141,11 @@ `()' #} fromJVal ::- (HsQMLJValHandle -> IO Bool) -> (HsQMLJValHandle -> IO a) ->+ Strength -> (HsQMLJValHandle -> IO Bool) -> (HsQMLJValHandle -> IO a) -> HsQMLJValHandle -> IO (Maybe a)-fromJVal isFn getFn jval = do+fromJVal Strong _ getFn jval =+ fmap Just $ getFn jval+fromJVal Weak isFn getFn jval = do is <- isFn jval if is then fmap Just $ getFn jval else return Nothing
src/Graphics/QML/Internal/Marshal.hs view
@@ -41,7 +41,7 @@ type MToCValFunc t = t -> Ptr () -> IO () type MWithCValFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b) -type MFromJValFunc t = HsQMLJValHandle -> ErrIO t+type MFromJValFunc t = Strength -> HsQMLJValHandle -> ErrIO t type MWithJValFunc t = (forall b. t -> (HsQMLJValHandle -> IO b) -> IO b) type MFromHndlFunc t = HsQMLObjectHandle -> IO t@@ -228,7 +228,7 @@ unimplToHndl _ = error "Type does not support mToHndl." jvalFromCVal :: (Marshal t) => MFromCValFunc t-jvalFromCVal = mFromJVal . HsQMLJValHandle . castPtr+jvalFromCVal = mFromJVal Strong . HsQMLJValHandle . castPtr jvalToCVal :: (Marshal t) => MToCValFunc t jvalToCVal val ptr = mWithJVal val $ \jval ->
src/Graphics/QML/Internal/MetaObj.hs view
@@ -69,7 +69,7 @@ memberKind :: MemberKind, memberName :: String, memberType :: TypeId,- memberParams :: [TypeId],+ memberParams :: [(String, TypeId)], memberFun :: UniformFunc, memberFunAux :: Maybe UniformFunc, memberKey :: Maybe MemberKey@@ -173,7 +173,7 @@ put $ state { mParamMap = mpMap'} mapM_ (writeInt . typeId) types- replicateM_ (length $ memberParams m) $ writeString ""+ mapM_ (writeString . fst) $ memberParams m writeMethod :: Member tt -> State MOCState () writeMethod m = do@@ -223,7 +223,7 @@ memberKey p memberTypes :: Member tt -> [TypeId]-memberTypes m = memberType m : memberParams m+memberTypes m = memberType m : (map snd $ memberParams m) typeId :: TypeId -> CUInt typeId (TypeId tyid) = fromIntegral tyid
src/Graphics/QML/Internal/Objects.hs view
@@ -28,8 +28,8 @@ mToCVal (AnyObjRef hndl) ptr, mWithCVal_ = \(ObjRef hndl) f -> mWithCVal (AnyObjRef hndl) f,- mFromJVal_ = \ptr -> do- anyObj <- mFromJVal ptr+ mFromJVal_ = \_ ptr -> do+ anyObj <- mFromJVal Weak ptr MaybeT $ fromAnyObjRefIO anyObj, mWithJVal_ = \(ObjRef hndl) f -> mWithJVal (AnyObjRef hndl) f,@@ -53,7 +53,7 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = jvalToCVal, mWithCVal_ = jvalWithCVal,- mFromJVal_ = \ptr -> MaybeT $ do+ mFromJVal_ = \_ ptr -> MaybeT $ do hndl <- hsqmlGetObjectFromJval ptr return $ if isNullObjectHandle hndl then Nothing else Just $ AnyObjRef hndl,
src/Graphics/QML/Internal/Types.hs view
@@ -18,3 +18,5 @@ cinfoObjType :: TypeRep, cinfoSignals :: Map MemberKey Int }++data Strength = Strong | Weak
src/Graphics/QML/Marshal.hs view
@@ -69,8 +69,8 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = jvalToCVal, mWithCVal_ = jvalWithCVal,- mFromJVal_ = \ptr ->- MaybeT $ fromJVal hsqmlIsJvalBool hsqmlGetJvalBool ptr,+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalBool hsqmlGetJvalBool ptr, mWithJVal_ = \bool f -> withJVal hsqmlInitJvalBool bool f, mFromHndl_ = unimplFromHndl,@@ -91,8 +91,8 @@ mWithCVal_ = \int f -> alloca $ \(ptr :: Ptr CInt) -> mToCVal int (castPtr ptr) >> f (castPtr ptr),- mFromJVal_ = \ptr ->- MaybeT $ fromJVal hsqmlIsJvalNumber (+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalNumber ( fmap fromIntegral . hsqmlGetJvalInt) ptr, mWithJVal_ = \int f -> withJVal hsqmlInitJvalInt (fromIntegral int) f,@@ -106,7 +106,7 @@ mFromCVal_ = fmap (fromIntegral :: Int32 -> Int) . mFromCVal, mToCVal_ = \int ptr -> mToCVal (fromIntegral int :: Int32) ptr, mWithCVal_ = \int f -> mWithCVal (fromIntegral int :: Int32) f,- mFromJVal_ = fmap (fromIntegral :: Int32 -> Int) . mFromJVal,+ mFromJVal_ = \s -> fmap (fromIntegral :: Int32 -> Int) . mFromJVal s, mWithJVal_ = \int f -> mWithJVal (fromIntegral int :: Int32) f, mFromHndl_ = unimplFromHndl, mToHndl_ = unimplToHndl}@@ -126,8 +126,8 @@ mWithCVal_ = \num f -> alloca $ \(ptr :: Ptr CDouble) -> mToCVal num (castPtr ptr) >> f (castPtr ptr),- mFromJVal_ = \ptr ->- MaybeT $ fromJVal hsqmlIsJvalNumber (+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalNumber ( fmap realToFrac . hsqmlGetJvalDouble) ptr, mWithJVal_ = \num f -> withJVal hsqmlInitJvalDouble (realToFrac num) f,@@ -157,9 +157,9 @@ withStrHndl $ \(HsQMLStringHandle ptr) -> do mToCVal txt $ castPtr ptr f $ castPtr ptr,- mFromJVal_ = \jval ->+ mFromJVal_ = \s jval -> MaybeT $ withStrHndl $ \sHndl -> runMaybeT $ do- MaybeT $ fromJVal hsqmlIsJvalString (+ MaybeT $ fromJVal s hsqmlIsJvalString ( flip hsqmlGetJvalString sHndl) jval let (HsQMLStringHandle ptr) = sHndl mFromCVal $ castPtr ptr,@@ -184,7 +184,7 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = jvalToCVal, mWithCVal_ = jvalWithCVal,- mFromJVal_ = \jval -> errIO $ runMaybeT $ mFromJVal jval,+ mFromJVal_ = \_ jval -> errIO $ runMaybeT $ mFromJVal Weak jval, mWithJVal_ = \val f -> case val of Just val' -> mWithJVal val' f@@ -207,12 +207,12 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = jvalToCVal, mWithCVal_ = jvalWithCVal,- mFromJVal_ = \jval -> MaybeT $ do+ mFromJVal_ = \s jval -> MaybeT $ do len <- hsqmlGetJvalArrayLength jval withJVal hsqmlInitJvalNull True $ \tmp -> runMaybeT $ forM [0..len-1] $ \i -> do errIO $ hsqmlJvalArrayGet jval i tmp- mFromJVal tmp,+ mFromJVal s tmp, mWithJVal_ = \vs f -> withJVal hsqmlInitJvalArray (length vs) $ \jval -> do forM_ (zip [0..] vs) $ uncurry $ \i val ->@@ -237,7 +237,7 @@ mFromCVal_ = jvalFromCVal, mToCVal_ = unimplToCVal, mWithCVal_ = unimplWithCVal,- mFromJVal_ = \_ -> MaybeT . return $ Just Ignored,+ mFromJVal_ = \_ _ -> MaybeT . return $ Just Ignored, mWithJVal_ = unimplWithJVal, mFromHndl_ = unimplFromHndl, mToHndl_ = unimplToHndl}@@ -261,7 +261,7 @@ mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr, mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val, mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,- mFromJVal_ = \ptr -> (errIO . fromFn) =<< mFromJVal ptr,+ mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr, mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val, mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl, mToHndl_ = \val -> mToHndl =<< toFn val}@@ -293,7 +293,7 @@ mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr, mToCVal_ = unimplToCVal, mWithCVal_ = unimplWithCVal,- mFromJVal_ = \ptr -> (errIO . fromFn) =<< mFromJVal ptr,+ mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr, mWithJVal_ = unimplWithJVal, mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl, mToHndl_ = unimplToHndl}
src/Graphics/QML/Objects.hs view
@@ -34,6 +34,7 @@ -- * Signals defSignal,+ defSignalNamedParams, fireSignal, SignalKey, newSignalKey,@@ -61,6 +62,7 @@ import Graphics.QML.Internal.MetaObj import Graphics.QML.Internal.Objects import Graphics.QML.Internal.Types+import Graphics.QML.Objects.ParamNames import Control.Concurrent.MVar import Data.Map (Map)@@ -283,7 +285,7 @@ in Member MethodMember name (methodReturnType crude)- (methodParamTypes crude)+ (map (\t->("",t)) $ methodParamTypes crude) (mkUniformFunc f) Nothing Nothing@@ -308,13 +310,21 @@ -- or ii) value-based using a 'SignalKey' value creating using 'newSignalKey'. defSignal :: forall obj skv. (SignalKeyValue skv) => String -> skv -> Member obj-defSignal name key =+defSignal name key = defSignalNamedParams name key anonParams++-- | Defines a named signal with named parameters. This is otherwise identical+-- to 'defSignal', but allows QML code to reference signal parameters by-name+-- in addition to by-position.+defSignalNamedParams :: forall obj skv. (SignalKeyValue skv) =>+ String -> skv ->+ ParamNames (SignalParamNames (SignalValueParams skv)) -> Member obj+defSignalNamedParams name key pnames = let crude = untag (mkSignalTypes :: Tagged (SignalValueParams skv) SignalTypeInfo) in Member SignalMember name tyVoid- (signalParamTypes crude)+ (paramNames pnames `zip` signalParamTypes crude) (\_ _ -> return ()) Nothing (Just $ signalKey key)@@ -376,13 +386,15 @@ signalKey (SignalKey u) = DataKey u -- | Supports marshalling an arbitrary number of arguments into a QML signal.-class SignalSuffix ss where+class (AnonParams (SignalParamNames ss)) => SignalSuffix ss where+ type SignalParamNames ss mkSignalArgs :: forall usr. ((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss mkSignalTypes :: Tagged ss SignalTypeInfo instance (Marshal a, CanPassTo a ~ Yes, SignalSuffix b) => SignalSuffix (a -> b) where+ type SignalParamNames (a -> b) = String -> SignalParamNames b mkSignalArgs start cont param = mkSignalArgs start (\ps usr -> mWithCVal param (\ptr ->@@ -394,6 +406,7 @@ in Tagged $ SignalTypeInfo (typ:p) instance SignalSuffix (IO ()) where+ type SignalParamNames (IO ()) = () mkSignalArgs start cont = start $ cont [] mkSignalTypes =
+ src/Graphics/QML/Objects/ParamNames.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE+ ScopedTypeVariables,+ FlexibleInstances+ #-}++-- | Parameter Name Lists+module Graphics.QML.Objects.ParamNames (+ ParamNames,+ paramNames,+ noNames,+ fstName,+ plusName,+ anonParams,+ AnonParams ()+) where++-- | Represents a list of parameter names. The number of names in the list is+-- statically encoded using the length of the function type held in the type+-- parameter @a@.+newtype ParamNames a = ParamNames ([String] -> [String])++instance Show (ParamNames a) where+ show (ParamNames nsFunc) =+ let showHead [] = showString "noNames"+ showHead (n:ns) = showString "fstName " . shows n . showTail ns+ showTail [] = id+ showTail (n:ns) = showString " `plusName` " . shows n . showTail ns+ in showHead (nsFunc []) ""++-- | Coverts a 'ParamNames' list to an ordinary list of strings.+paramNames :: ParamNames a -> [String]+paramNames (ParamNames names) = names []++-- | Adds one parameter name to a 'ParamNames' list.+plusName :: ParamNames a -> String -> ParamNames (String -> a)+plusName (ParamNames ns) n = ParamNames $ ns . (n:)++-- | An empty 'ParamNames' list.+noNames :: ParamNames ()+noNames = ParamNames id++-- | Produces a 'ParamNames' list with a single name.+fstName :: String -> ParamNames (String -> ())+fstName = (noNames `plusName`)++-- | Helper class for generating anonymous parameter lists.+class AnonParams a where+ anonParams_ :: ParamNames a++instance (AnonParams b) => AnonParams (String -> b) where+ anonParams_ = plusName (anonParams_ :: ParamNames b) ""++instance AnonParams () where+ anonParams_ = noNames++-- | Polymorphically produces 'ParamNames' lists of any length filled with+-- blank parameter names.+anonParams :: (AnonParams a) => ParamNames a+anonParams = anonParams_