hsqml 0.2.0.3 → 0.3.0.0
raw patch · 43 files changed
+2773/−2397 lines, 43 filesdep −networkdep ~QuickCheckdep ~hsqmlsetup-changed
Dependencies removed: network
Dependency ranges changed: QuickCheck, hsqml
Files
- CHANGELOG +17/−2
- Setup.hs +67/−32
- cbits/Class.cpp +163/−0
- cbits/Class.h +40/−0
- cbits/Engine.cpp +107/−0
- cbits/Engine.h +48/−0
- cbits/HsQMLClass.cpp +0/−146
- cbits/HsQMLClass.h +0/−39
- cbits/HsQMLEngine.cpp +0/−95
- cbits/HsQMLEngine.h +0/−68
- cbits/HsQMLIntrinsics.cpp +0/−77
- cbits/HsQMLManager.cpp +0/−325
- cbits/HsQMLManager.h +0/−109
- cbits/HsQMLObject.cpp +0/−329
- cbits/HsQMLObject.h +0/−71
- cbits/HsQMLWindow.cpp +0/−107
- cbits/HsQMLWindow.h +0/−45
- cbits/Intrinsics.cpp +169/−0
- cbits/Manager.cpp +325/−0
- cbits/Manager.h +123/−0
- cbits/Object.cpp +348/−0
- cbits/Object.h +72/−0
- cbits/hsqml.h +71/−19
- hsqml.cabal +28/−18
- src/Graphics/QML.hs +0/−18
- src/Graphics/QML/Engine.hs +27/−54
- src/Graphics/QML/Internal/BindCore.chs +2/−4
- src/Graphics/QML/Internal/BindObj.chs +18/−9
- src/Graphics/QML/Internal/BindPrim.chs +127/−19
- src/Graphics/QML/Internal/Marshal.hs +181/−73
- src/Graphics/QML/Internal/MetaObj.hs +87/−35
- src/Graphics/QML/Internal/Objects.hs +0/−122
- src/Graphics/QML/Internal/Types.hs +21/−0
- src/Graphics/QML/Marshal.hs +225/−104
- src/Graphics/QML/Objects.hs +334/−244
- test/Graphics/QML/Test/DataTest.hs +53/−0
- test/Graphics/QML/Test/Framework.hs +22/−9
- test/Graphics/QML/Test/GenURI.hs +0/−51
- test/Graphics/QML/Test/Harness.hs +20/−12
- test/Graphics/QML/Test/ScriptDSL.hs +21/−12
- test/Graphics/QML/Test/SignalTest.hs +19/−61
- test/Graphics/QML/Test/SimpleTest.hs +12/−84
- test/Test1.hs +26/−4
CHANGELOG view
@@ -1,9 +1,24 @@ HsQML - Release History +release-0.3.0.0 - 2014.05.04++ * Ported to Qt 5 and Qt Quick 2+ * Added type-free mechanism for defining classes.+ * Added type-free mechanism for defining signal keys.+ * Added property signals.+ * Added marshallers for Bool, Maybe, and lists.+ * Added less polymorphic aliases for def functions.+ * Replaced Tagged with Proxy in public API.+ * Removed marshallers for URI and String.+ * New design for marshalling type-classes (again).+ * Generalised facility for user-defined Marshal instances.+ * Relaxed Cabal dependency constraint on 'QuickCheck'.+ * Fixed GHCi on Windows with pre-7.8 GHC.+ release-0.2.0.3 - 2014.02.01 - * Added mechanism to force enable GHCi workaround library. - * Fixed reference name of extra GHCi library on Windows.+ * Added mechanism to force enable GHCi workaround library.+ * Fixed reference name of extra GHCi library. release-0.2.0.2 - 2014.01.18
Setup.hs view
@@ -71,12 +71,15 @@ copyHook = copyWithQt, instHook = instWithQt, regHook = regWithQt} +getCustomStr :: String -> PackageDescription -> String+getCustomStr name pkgDesc =+ fromMaybe "" $ do+ lib <- library pkgDesc+ lookup name $ customFieldsBI $ libBuildInfo lib+ getCustomFlag :: String -> PackageDescription -> Bool getCustomFlag name pkgDesc =- fromMaybe False $ do- lib <- library pkgDesc- str <- lookup name $ customFieldsBI $ libBuildInfo lib- simpleParse str+ fromMaybe False . simpleParse $ getCustomStr name pkgDesc confWithQt :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo@@ -84,11 +87,12 @@ let verb = fromFlag $ configVerbosity flags mocPath <- findProgramLocation verb "moc" cppPath <- findProgramLocation verb "cpp"- let condLib = fromJust $ condLibrary gpd- fixCondLib lib = lib {- libBuildInfo = substPaths mocPath cppPath $ libBuildInfo lib} - condLib' = mapCondTree fixCondLib condLib- gpd' = gpd {condLibrary = Just $ condLib'}+ let mapLibBI = fmap . mapCondTree . mapBI $ substPaths mocPath cppPath+ gpd' = gpd {+ condLibrary = mapLibBI $ condLibrary gpd,+ condExecutables = mapAllBI mocPath cppPath $ condExecutables gpd,+ condTestSuites = mapAllBI mocPath cppPath $ condTestSuites gpd,+ condBenchmarks = mapAllBI mocPath cppPath $ condBenchmarks gpd} lbi <- confHook simpleUserHooks (gpd',hbi) flags -- Find Qt moc program and store in database (_,_,db') <- requireProgramVersion verb@@ -101,6 +105,11 @@ return lbi {withPrograms = db', withGHCiLib = withGHCiLib lbi || forceGHCiLib} +mapAllBI :: (HasBuildInfo a) => Maybe FilePath -> Maybe FilePath ->+ [(x, CondTree c v a)] -> [(x, CondTree c v a)]+mapAllBI mocPath cppPath =+ mapSnd . mapCondTree . mapBI $ substPaths mocPath cppPath+ mapCondTree :: (a -> a) -> CondTree v c a -> CondTree v c a mapCondTree f (CondNode val cnstr cs) = CondNode (f val) cnstr $ map updateChildren cs@@ -110,16 +119,14 @@ substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo substPaths mocPath cppPath build = let toRoot = takeDirectory . takeDirectory . fromMaybe ""- substPath = replacePrefix "/QT_ROOT" (toRoot mocPath) .- replacePrefix "/SYS_ROOT" (toRoot cppPath)- in build {extraLibDirs = map substPath $ extraLibDirs build,- includeDirs = map substPath $ includeDirs build}--replacePrefix :: (Eq a) => [a] -> [a] -> [a] -> [a]-replacePrefix old new xs =- case stripPrefix old xs of- Just ys -> new ++ ys- Nothing -> xs+ substPath = replace "/QT_ROOT" (toRoot mocPath) .+ replace "/SYS_ROOT" (toRoot cppPath)+ in build {ccOptions = map substPath $ ccOptions build,+ ldOptions = map substPath $ ldOptions build,+ extraLibDirs = map substPath $ extraLibDirs build,+ includeDirs = map substPath $ includeDirs build,+ options = mapSnd (map substPath) $ options build,+ customFieldsBI = mapSnd substPath $ customFieldsBI build} buildWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()@@ -128,10 +135,7 @@ libs' <- maybeMapM (\lib -> fmap (\lib' -> lib {libBuildInfo = lib'}) $ fixQtBuild verb lbi $ libBuildInfo lib) $ library pkgDesc- exes' <- mapM (\exe -> fmap (\exe' ->- exe {buildInfo = exe'}) $ fixQtBuild verb lbi $ buildInfo exe) $- executables pkgDesc- let pkgDesc' = pkgDesc {library = libs', executables = exes'}+ let pkgDesc' = pkgDesc {library = libs'} lbi' = if (needsGHCiFix pkgDesc lbi) then lbi {withGHCiLib = False, splitObjs = False} else lbi buildHook simpleUserHooks pkgDesc' lbi' hooks flags@@ -201,17 +205,17 @@ programFindLocation = adaptFindLoc $ \verb -> findProgramLocation verb "moc", programFindVersion = \verb path -> do- (_,line,_) <- rawSystemStdErr verb path ["-v"]+ (oLine,eLine,_) <- rawSystemStdErr verb path ["-v"] return $- findSubseq (stripPrefix "(Qt ") line >>=- Just . takeWhile (\c -> isDigit c || c == '.') >>=- simpleParse,+ (findSubseq (stripPrefix "(Qt ") eLine `mplus`+ findSubseq (stripPrefix "moc ") oLine) >>=+ simpleParse . takeWhile (\c -> isDigit c || c == '.'), programPostConf = noPostConf } qtVersionRange :: VersionRange qtVersionRange = intersectVersionRanges- (orLaterVersion $ Version [4,7] []) (earlierVersion $ Version [5,0] [])+ (orLaterVersion $ Version [5,0] []) (earlierVersion $ Version [6,0] []) copyWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()@@ -235,10 +239,15 @@ clbi = extractCLBI lbi instPkgInfo <- generateRegistrationInfo verb pkg lib lbi clbi inplace dist- let instPkgInfo' = if (needsGHCiFix pkg lbi)- then instPkgInfo {I.extraGHCiLibraries =- mkGHCiFixLibRefName pkg : I.extraGHCiLibraries instPkgInfo}- else instPkgInfo+ let instPkgInfo' = instPkgInfo {+ -- Add extra library for GHCi workaround+ I.extraGHCiLibraries =+ (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg] else []) +++ I.extraGHCiLibraries instPkgInfo,+ -- Add directories to framework search path+ I.frameworkDirs =+ words (getCustomStr "x-framework-dirs" pkg) +++ I.frameworkDirs instPkgInfo} case flagToMaybe $ regGenPkgConf flags of Just regFile -> do writeUTF8File (fromMaybe (display (packageId pkg) <.> "conf") regFile) $@@ -267,12 +276,38 @@ copyWithQt pkgDesc lbi hooks copyFlags when (hasLibs pkgDesc) $ regWithQt pkgDesc lbi hooks regFlags +class HasBuildInfo a where+ mapBI :: (BuildInfo -> BuildInfo) -> a -> a++instance HasBuildInfo Library where+ mapBI f x = x {libBuildInfo = f $ libBuildInfo x} ++instance HasBuildInfo Executable where+ mapBI f x = x {buildInfo = f $ buildInfo x} ++instance HasBuildInfo TestSuite where+ mapBI f x = x {testBuildInfo = f $ testBuildInfo x} ++instance HasBuildInfo Benchmark where+ mapBI f x = x {benchmarkBuildInfo = f $ benchmarkBuildInfo x} + maybeMapM :: (Monad m) => (a -> m b) -> (Maybe a) -> m (Maybe b) maybeMapM f = maybe (return Nothing) $ liftM Just . f +mapSnd :: (a -> a) -> [(x, a)] -> [(x, a)]+mapSnd f = map (\(x,y) -> (x,f y))+ findSubseq :: ([a] -> Maybe b) -> [a] -> Maybe b findSubseq f [] = f [] findSubseq f xs@(_:ys) = case f xs of Nothing -> findSubseq f ys Just r -> Just r++replace :: (Eq a) => [a] -> [a] -> [a] -> [a]+replace [] _ xs = xs+replace _ _ [] = []+replace src dst xs@(x:xs') =+ case stripPrefix src xs of+ Just xs'' -> dst ++ replace src dst xs''+ Nothing -> x : replace src dst xs'
+ cbits/Class.cpp view
@@ -0,0 +1,163 @@+#include <cstdlib>+#include <cstring>+#include <HsFFI.h>+#include <QtCore/QMetaObject>+#include <QtCore/QMetaType>+#include <QtCore/QString>++#include "hsqml.h"+#include "Class.h"+#include "Manager.h"++enum MDFields {+ MD_METHOD_COUNT = 4,+ MD_PROPERTY_COUNT = 6,+};++static const char* cRefSrcNames[] = {"Hndl", "Proxy"};++HsQMLClass::HsQMLClass(+ unsigned int* metaData,+ unsigned int* metaStrInfo,+ char* metaStrChar,+ HsStablePtr hsTypeRep,+ HsQMLUniformFunc* methods,+ HsQMLUniformFunc* properties)+ : mRefCount(0)+ , mMetaData(metaData)+ , mHsTypeRep(hsTypeRep)+ , mMethodCount(metaData[MD_METHOD_COUNT])+ , mPropertyCount(metaData[MD_PROPERTY_COUNT])+ , mMethods(methods)+ , mProperties(properties)+{+ // Create string data+ unsigned int strCount = metaStrInfo[0];+ unsigned int strLength = metaStrInfo[strCount];+ size_t arrayOff = strCount*sizeof(QByteArrayData);+ size_t arraySize = arrayOff+strLength;+ mMetaStrData.reset(new char[arraySize]);+ for (int i=0; i<strCount; i++) {+ int start = i > 0 ? metaStrInfo[i] : 0;+ int size = metaStrInfo[i+1] - start;+ int offset = arrayOff-(i*sizeof(QByteArrayData))+start;+ QByteArrayData data = {+ Q_REFCOUNT_INITIALIZE_STATIC, size-1, 0, 0, offset};+ new(&mMetaStrData[i*sizeof(QByteArrayData)]) QByteArrayData(data);+ }+ std::memcpy(&mMetaStrData[arrayOff], metaStrChar, strLength);++ // Create meta-object+ QMetaObject metaObj = {+ &QObject::staticMetaObject,+ reinterpret_cast<QByteArrayData*>(mMetaStrData.data()),+ mMetaData,+ 0,+ 0};+ mMetaObject = metaObj;++ // Add reference+ ref(Handle);++ gManager->updateCounter(HsQMLManager::ClassCount, 1);+}++HsQMLClass::~HsQMLClass()+{+ for (int i=0; i<mMethodCount; i++) {+ gManager->freeFun((HsFunPtr)mMethods[i]);+ }+ for (unsigned int i=0; i<2*mPropertyCount; i++) {+ if (mProperties[i]) {+ gManager->freeFun((HsFunPtr)mProperties[i]);+ }+ }+ gManager->freeStable(mHsTypeRep);+ std::free(mMetaData);+ std::free(mMethods);+ std::free(mProperties);++ gManager->updateCounter(HsQMLManager::ClassCount, -1);+}++const char* HsQMLClass::name()+{+ return mMetaObject.className();+} ++HsStablePtr HsQMLClass::hsTypeRep()+{+ return mHsTypeRep;+}++int HsQMLClass::methodCount()+{+ return mMethodCount;+}++int HsQMLClass::propertyCount()+{+ return mPropertyCount;+}++const HsQMLUniformFunc* HsQMLClass::methods()+{+ return mMethods;+}++const HsQMLUniformFunc* HsQMLClass::properties()+{+ return mProperties;+}++const QMetaObject* HsQMLClass::metaObj()+{+ return &mMetaObject;+}++void HsQMLClass::ref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(1);++ HSQML_LOG(count == 0 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count ? "Ref" : "New", name(), cRefSrcNames[src], count+1));+}++void HsQMLClass::deref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(-1);++ HSQML_LOG(count == 1 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count));++ if (count == 1) {+ delete this;+ }+}++extern "C" int hsqml_get_next_class_id()+{+ return gManager->updateCounter(HsQMLManager::ClassSerial, 1);+}++extern "C" HsQMLClassHandle* hsqml_create_class(+ unsigned int* metaData,+ unsigned int* metaStrInfo,+ char* metaStrChar,+ HsStablePtr hsTypeRep,+ HsQMLUniformFunc* methods,+ HsQMLUniformFunc* properties)+{+ HsQMLClass* klass = new HsQMLClass(+ metaData, metaStrInfo, metaStrChar, hsTypeRep, methods, properties);+ return (HsQMLClassHandle*)klass;+}++extern "C" void hsqml_finalise_class_handle(+ HsQMLClassHandle* hndl)+{+ HsQMLClass* klass = (HsQMLClass*)hndl;+ klass->deref(HsQMLClass::Handle);+}
+ cbits/Class.h view
@@ -0,0 +1,40 @@+#ifndef HSQML_CLASS_H+#define HSQML_CLASS_H++#include <QtCore/QObject>+#include <QtCore/QAtomicInt>+#include <QtCore/QScopedArrayPointer>++#include "hsqml.h"++class HsQMLClass+{+public:+ HsQMLClass(+ unsigned int*, unsigned int*, char*,+ HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*);+ ~HsQMLClass();+ const char* name();+ HsStablePtr hsTypeRep();+ int methodCount();+ int propertyCount();+ const HsQMLUniformFunc* methods();+ const HsQMLUniformFunc* properties();+ const QMetaObject* metaObj();+ enum RefSrc {Handle, ObjProxy};+ void ref(RefSrc);+ void deref(RefSrc);++private:+ QAtomicInt mRefCount;+ unsigned int* mMetaData;+ QScopedArrayPointer<char> mMetaStrData;+ HsStablePtr mHsTypeRep;+ int mMethodCount;+ int mPropertyCount;+ HsQMLUniformFunc* mMethods;+ HsQMLUniformFunc* mProperties;+ QMetaObject mMetaObject;+};++#endif /*HSQML_CLASS_H*/
+ cbits/Engine.cpp view
@@ -0,0 +1,107 @@+#include <QtQuick/QQuickItem>+#include <QtQuick/QQuickWindow>++#include "Manager.h"+#include "Engine.h"+#include "Object.h"++HsQMLEngine::HsQMLEngine(const HsQMLEngineConfig& config)+ : mComponent(&mEngine)+ , mStopCb(config.stopCb)+{+ // Connect signals+ QObject::connect(+ &mEngine, SIGNAL(quit()),+ this, SLOT(deleteLater()));+ QObject::connect(+ &mComponent, SIGNAL(statusChanged(QQmlComponent::Status)),+ this, SLOT(componentStatus(QQmlComponent::Status)));++ // Obtain, re-parent, and set QML global object+ if (config.contextObject) {+ QObject* ctx = config.contextObject->object(this);+ mEngine.rootContext()->setContextObject(ctx);+ mObjects << ctx;+ }++ // Load document+ mComponent.loadUrl(QUrl(config.initialURL));+}++HsQMLEngine::~HsQMLEngine()+{+ // Call stop callback+ mStopCb();+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mStopCb));++ // Delete owned objects+ qDeleteAll(mObjects);+}++bool HsQMLEngine::eventFilter(QObject* obj, QEvent* ev)+{+ if (QEvent::Close == ev->type()) {+ deleteLater();+ }+ return false;+}++QQmlEngine* HsQMLEngine::declEngine()+{+ return &mEngine;+}++void HsQMLEngine::componentStatus(QQmlComponent::Status status)+{+ switch (status) {+ case QQmlComponent::Ready: {+ QObject* obj = mComponent.create();+ mObjects << obj;+ QQuickWindow* win = qobject_cast<QQuickWindow*>(obj);+ QQuickItem* item = qobject_cast<QQuickItem*>(obj);+ if (item) {+ win = new QQuickWindow();+ mObjects << win;+ item->setParentItem(win->contentItem());+ int width = item->width();+ int height = item->height();+ if (width < 1 || height < 1) {+ width = item->implicitWidth();+ height = item->implicitHeight();+ }+ win->setWidth(width);+ win->setHeight(height);+ win->contentItem()->setWidth(width);+ win->contentItem()->setHeight(height);+ win->setTitle("HsQML Window");+ win->show();+ }+ if (win) {+ win->installEventFilter(this);+ mEngine.setIncubationController(win->incubationController());+ }+ break;}+ case QQmlComponent::Error: {+ QList<QQmlError> errs = mComponent.errors();+ for (QList<QQmlError>::iterator it = errs.begin();+ it != errs.end(); ++it) {+ HSQML_LOG(0, it->toString());+ }+ deleteLater();+ break;}+ }+}++extern "C" void hsqml_create_engine(+ HsQMLObjectHandle* contextObject,+ HsQMLStringHandle* initialURL,+ HsQMLTrivialCb stopCb)+{+ HsQMLEngineConfig config;+ config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);+ config.initialURL = *reinterpret_cast<QString*>(initialURL);+ config.stopCb = stopCb;++ Q_ASSERT (gManager);+ gManager->createEngine(config);+}
+ cbits/Engine.h view
@@ -0,0 +1,48 @@+#ifndef HSQML_ENGINE_H+#define HSQML_ENGINE_H++#include <QtCore/QScopedPointer>+#include <QtCore/QString>+#include <QtCore/QUrl>+#include <QtQml/QQmlEngine>+#include <QtQml/QQmlContext>+#include <QtQml/QQmlComponent>++#include "hsqml.h"++class HsQMLObjectProxy;+class HsQMLWindow;++struct HsQMLEngineConfig+{+ HsQMLEngineConfig()+ : contextObject(NULL)+ , stopCb(NULL)+ {}++ HsQMLObjectProxy* contextObject;+ QString initialURL;+ HsQMLTrivialCb stopCb;+};++class HsQMLEngine : public QObject+{+ Q_OBJECT++public:+ HsQMLEngine(const HsQMLEngineConfig&);+ ~HsQMLEngine();+ bool eventFilter(QObject*, QEvent*);+ QQmlEngine* declEngine();++private:+ Q_DISABLE_COPY(HsQMLEngine)++ Q_SLOT void componentStatus(QQmlComponent::Status);+ QQmlEngine mEngine;+ QQmlComponent mComponent;+ QList<QObject*> mObjects;+ HsQMLTrivialCb mStopCb;+};++#endif /*HSQML_ENGINE_H*/
− cbits/HsQMLClass.cpp
@@ -1,146 +0,0 @@-#include <cstdlib>-#include <HsFFI.h>-#include <QtCore/QMetaObject>-#include <QtCore/QMetaType>-#include <QtCore/QString>--#include "hsqml.h"-#include "HsQMLClass.h"-#include "HsQMLManager.h"--enum MDFields {- MD_METHOD_COUNT = 4,- MD_PROPERTY_COUNT = 6,-};--static const char* cRefSrcNames[] = {"Hndl", "Proxy"};--HsQMLClass::HsQMLClass(- unsigned int* metaData,- char* metaStrData,- HsStablePtr hsTypeRep,- HsQMLUniformFunc* methods,- HsQMLUniformFunc* properties)- : mRefCount(0)- , mMetaData(metaData)- , mMetaStrData(metaStrData)- , mHsTypeRep(hsTypeRep)- , mMethodCount(metaData[MD_METHOD_COUNT])- , mPropertyCount(metaData[MD_PROPERTY_COUNT])- , mMethods(methods)- , mProperties(properties)-{- // Create meta-object- QMetaObject tmp = {- &QObject::staticMetaObject,- mMetaStrData,- mMetaData,- 0};- mMetaObject = new QMetaObject(tmp);-- // Add reference- ref(Handle);-- gManager->updateCounter(HsQMLManager::ClassCount, 1);-}--HsQMLClass::~HsQMLClass()-{- for (int i=0; i<mMethodCount; i++) {- gManager->freeFun((HsFunPtr)mMethods[i]);- }- for (unsigned int i=0; i<2*mPropertyCount; i++) {- if (mProperties[i]) {- gManager->freeFun((HsFunPtr)mProperties[i]);- }- }- gManager->freeStable(mHsTypeRep);- std::free(mMetaData);- std::free(mMetaStrData);- std::free(mMethods);- std::free(mProperties);- delete mMetaObject;-- gManager->updateCounter(HsQMLManager::ClassCount, -1);-}--const char* HsQMLClass::name()-{- return mMetaObject->className();-} --HsStablePtr HsQMLClass::hsTypeRep()-{- return mHsTypeRep;-}--int HsQMLClass::methodCount()-{- return mMethodCount;-}--int HsQMLClass::propertyCount()-{- return mPropertyCount;-}--const HsQMLUniformFunc* HsQMLClass::methods()-{- return mMethods;-}--const HsQMLUniformFunc* HsQMLClass::properties()-{- return mProperties;-}--const QMetaObject* HsQMLClass::metaObj()-{- return mMetaObject;-}--void HsQMLClass::ref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(1);-- HSQML_LOG(count == 0 ? 1 : 2,- QString().sprintf("%s Class, name=%s, src=%s, count=%d.",- count ? "Ref" : "New", name(), cRefSrcNames[src], count+1));-}--void HsQMLClass::deref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(-1);-- HSQML_LOG(count == 1 ? 1 : 2,- QString().sprintf("%s Class, name=%s, src=%s, count=%d.",- count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count));-- if (count == 1) {- delete this;- }-}--extern "C" int hsqml_get_next_class_id()-{- return gManager->updateCounter(HsQMLManager::ClassSerial, 1);-}--extern "C" HsQMLClassHandle* hsqml_create_class(- unsigned int* metaData,- char* metaStrData,- HsStablePtr hsTypeRep,- HsQMLUniformFunc* methods,- HsQMLUniformFunc* properties)-{- HsQMLClass* klass = new HsQMLClass(- metaData, metaStrData, hsTypeRep, methods, properties);- return (HsQMLClassHandle*)klass;-}--extern "C" void hsqml_finalise_class_handle(- HsQMLClassHandle* hndl)-{- HsQMLClass* klass = (HsQMLClass*)hndl;- klass->deref(HsQMLClass::Handle);-}
− cbits/HsQMLClass.h
@@ -1,39 +0,0 @@-#ifndef HSQML_CLASS_H-#define HSQML_CLASS_H--#include <QtCore/QObject>-#include <QtCore/QAtomicInt>--#include "hsqml.h"--class HsQMLClass-{-public:- HsQMLClass(- unsigned int*, char*, HsStablePtr,- HsQMLUniformFunc*, HsQMLUniformFunc*);- ~HsQMLClass();- const char* name();- HsStablePtr hsTypeRep();- int methodCount();- int propertyCount();- const HsQMLUniformFunc* methods();- const HsQMLUniformFunc* properties();- const QMetaObject* metaObj();- enum RefSrc {Handle, ObjProxy};- void ref(RefSrc);- void deref(RefSrc);--private:- QAtomicInt mRefCount;- unsigned int* mMetaData;- char* mMetaStrData;- HsStablePtr mHsTypeRep;- int mMethodCount;- int mPropertyCount;- HsQMLUniformFunc* mMethods;- HsQMLUniformFunc* mProperties;- QMetaObject* mMetaObject;-};--#endif /*HSQML_CLASS_H*/
− cbits/HsQMLEngine.cpp
@@ -1,95 +0,0 @@-#include "HsQMLManager.h"-#include "HsQMLEngine.h"-#include "HsQMLObject.h"-#include "HsQMLWindow.h"--HsQMLScriptHack::HsQMLScriptHack(QDeclarativeEngine* declEng)- : mEngine(NULL)-{- QDeclarativeEngine::setObjectOwnership(- this, QDeclarativeEngine::CppOwnership);- QDeclarativeExpression expr(declEng->rootContext(), this, "hack(self());");- expr.evaluate();- Q_ASSERT(!expr.hasError());-}--QObject* HsQMLScriptHack::self()-{- return this;-}--void HsQMLScriptHack::hack(QScriptValue value)-{- mEngine = value.engine();-}--QScriptEngine* HsQMLScriptHack::scriptEngine() const-{- return mEngine;-}--HsQMLEngine::HsQMLEngine(const HsQMLEngineConfig& config)- : mScriptEngine(HsQMLScriptHack(&mDeclEngine).scriptEngine())- , mStopCb(config.stopCb)-{- // Obtain, re-parent, and set QML global object- if (config.contextObject) {- mContextObj.reset(config.contextObject->object(this));- mDeclEngine.rootContext()->setContextObject(mContextObj.data());- }-- // Create window- HsQMLWindow* win = new HsQMLWindow(this);- win->setParent(this);- win->setSource(config.initialURL);- win->setVisible(config.showWindow);- if (config.setWindowTitle) {- win->setTitle(config.windowTitle);- }-}--HsQMLEngine::~HsQMLEngine()-{- // Call stop callback- mStopCb();- gManager->freeFun(reinterpret_cast<HsFunPtr>(mStopCb));-}--void HsQMLEngine::childEvent(QChildEvent* ev)-{- if (ev->removed() && children().size() == 0) {- deleteLater();- }-}--QDeclarativeEngine* HsQMLEngine::declEngine()-{- return &mDeclEngine;-}--QScriptEngine* HsQMLEngine::scriptEngine()-{- return mScriptEngine;-}--extern "C" void hsqml_create_engine(- HsQMLObjectHandle* contextObject,- HsQMLUrlHandle* initialURL,- int showWindow,- int setWindowTitle,- HsQMLStringHandle* windowTitle,- HsQMLTrivialCb stopCb)-{- HsQMLEngineConfig config;- config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);- config.initialURL = *reinterpret_cast<QUrl*>(initialURL);- config.showWindow = static_cast<bool>(showWindow);- if (setWindowTitle) {- config.setWindowTitle = true;- config.windowTitle = *reinterpret_cast<QString*>(windowTitle);- }- config.stopCb = stopCb;-- Q_ASSERT (gManager);- gManager->createEngine(config);-}
− cbits/HsQMLEngine.h
@@ -1,68 +0,0 @@-#ifndef HSQML_ENGINE_H-#define HSQML_ENGINE_H--#include <QtCore/QScopedPointer>-#include <QtCore/QString>-#include <QtCore/QUrl>-#include <QtScript/QScriptEngine>-#include <QtScript/QScriptValue>-#include <QtDeclarative/QDeclarativeEngine>-#include <QtDeclarative/QDeclarativeExpression>--#include "hsqml.h"--class HsQMLObjectProxy;-class HsQMLWindow;--struct HsQMLEngineConfig-{- HsQMLEngineConfig()- : contextObject(NULL)- , showWindow(false)- , setWindowTitle(false)- , stopCb(NULL)- {}-- HsQMLObjectProxy* contextObject;- QUrl initialURL;- bool showWindow;- bool setWindowTitle;- QString windowTitle;- HsQMLTrivialCb stopCb;-};--class HsQMLScriptHack : public QObject-{- Q_OBJECT--public:- HsQMLScriptHack(QDeclarativeEngine*);- Q_INVOKABLE virtual QObject* self();- Q_INVOKABLE virtual void hack(QScriptValue);- QScriptEngine* scriptEngine() const;--private:- QScriptEngine* mEngine;-};--class HsQMLEngine : public QObject-{- Q_OBJECT--public:- HsQMLEngine(const HsQMLEngineConfig&);- ~HsQMLEngine();- virtual void childEvent(QChildEvent*);- QDeclarativeEngine* declEngine();- QScriptEngine* scriptEngine();--private:- Q_DISABLE_COPY(HsQMLEngine)-- QDeclarativeEngine mDeclEngine;- QScriptEngine* mScriptEngine;- QScopedPointer<QObject> mContextObj;- HsQMLTrivialCb mStopCb;-};--#endif /*HSQML_ENGINE_H*/
− cbits/HsQMLIntrinsics.cpp
@@ -1,77 +0,0 @@-#include <cstdlib>-#include <cstring>--#include <QtCore/QString>-#include <QtCore/QUrl>--#include "hsqml.h"--/* String */-extern "C" size_t hsqml_get_string_size()-{- return sizeof(QString);-}--extern "C" void hsqml_init_string(HsQMLStringHandle* hndl)-{- new((void*)hndl) QString();-}--extern "C" void hsqml_deinit_string(HsQMLStringHandle* hndl)-{- QString* string = (QString*)hndl;- string->~QString();-}--extern "C" UTF16* hsqml_marshal_string(- int bufLen, HsQMLStringHandle* hndl)-{- QString* string = (QString*)hndl;- string->resize(bufLen);- return reinterpret_cast<UTF16*>(string->data());-}--extern "C" int hsqml_unmarshal_string(- HsQMLStringHandle* hndl, UTF16** bufPtr)-{- QString* string = (QString*)hndl;- *bufPtr = reinterpret_cast<UTF16*>(string->data());- return string->length();-}--/* URL */-extern "C" size_t hsqml_get_url_size()-{- return sizeof(QUrl);-}--extern "C" void hsqml_init_url(HsQMLUrlHandle* hndl)-{- new((void*)hndl) QUrl();-}--extern "C" void hsqml_deinit_url(HsQMLUrlHandle* hndl)-{- QUrl* url = (QUrl*)hndl;- url->~QUrl();-}--extern "C" void hsqml_marshal_url(- char* buf, int bufLen, HsQMLUrlHandle* hndl)-{- QUrl* url = (QUrl*)hndl;- QByteArray cstr(buf, bufLen);- url->setEncodedUrl(cstr, QUrl::StrictMode);-}--extern "C" int hsqml_unmarshal_url(- HsQMLUrlHandle* hndl, char** bufPtr)-{- QUrl* url = (QUrl*)hndl;- QByteArray cstr = url->toEncoded();- int bufLen = cstr.length();- char* buf = reinterpret_cast<char*>(malloc(bufLen));- memcpy(buf, cstr.data(), bufLen);- *bufPtr = buf;- return bufLen;-}
− cbits/HsQMLManager.cpp
@@ -1,325 +0,0 @@-#include <iostream>-#include <cstdlib>-#include <QtCore/QBasicTimer>-#include <QtCore/QMetaType>-#include <QtCore/QMutexLocker>-#include <QtCore/QThread>-#ifdef Q_WS_MAC-#include <pthread.h>-#endif--#include "HsQMLManager.h"-#include "HsQMLObject.h"--static const char* cCounterNames[] = {- "ClassCounter",- "ObjectCounter",- "QObjectCounter",- "ClassSerial",- "ObjectSerial"-};--extern "C" void hsqml_dump_counters()-{- Q_ASSERT (gManager);- if (gManager->checkLogLevel(1)) {- for (int i=0; i<HsQMLManager::TotalCounters; i++) {- gManager->log(QString().sprintf("%s = %d.",- cCounterNames[i], gManager->updateCounter(- static_cast<HsQMLManager::CounterId>(i), 0)));- }- }-}--QAtomicPointer<HsQMLManager> gManager;--HsQMLManager::HsQMLManager(- void (*freeFun)(HsFunPtr),- void (*freeStable)(HsStablePtr))- : mLogLevel(0)- , mAtExit(false)- , mFreeFun(freeFun)- , mFreeStable(freeStable)- , mApp(NULL)- , mLock(QMutex::Recursive)- , mRunning(false)- , mRunCount(0)- , mStartCb(NULL)- , mJobsCb(NULL)- , mYieldCb(NULL)- , mActiveEngine(NULL)-{- qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");-- const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL");- if (env) {- setLogLevel(QString(env).toInt());- }-}--void HsQMLManager::setLogLevel(int ll)-{- mLogLevel = ll;- if (ll > 0 && !mAtExit) {- if (atexit(&hsqml_dump_counters) == 0) {- mAtExit = true;- }- else {- log("Failed to register callback with atexit().");- }- }-}--bool HsQMLManager::checkLogLevel(int ll)-{- return mLogLevel >= ll;-}--void HsQMLManager::log(const QString& msg)-{- std::cerr << "HsQML: " << msg.toStdString() << std::endl;-}--int HsQMLManager::updateCounter(CounterId id, int delta)-{- return mCounters[id].fetchAndAddRelaxed(delta);-}--void HsQMLManager::freeFun(HsFunPtr funPtr)-{- mFreeFun(funPtr);-}--void HsQMLManager::freeStable(HsStablePtr stablePtr)-{- mFreeStable(stablePtr);-}--bool HsQMLManager::isEventThread()-{- return mApp && mApp->thread() == QThread::currentThread();-}--HsQMLManager::EventLoopStatus HsQMLManager::runEventLoop(- HsQMLTrivialCb startCb,- HsQMLTrivialCb jobsCb,- HsQMLTrivialCb yieldCb)-{- QMutexLocker locker(&mLock);-- // Check if already running- if (mRunning) {- return HSQML_EVLOOP_ALREADY_RUNNING;- }-- // Check if event loop bound to a different thread- if (mApp && !isEventThread()) {- return HSQML_EVLOOP_WRONG_THREAD;- }--#ifdef Q_WS_MAC- if (!pthread_main_np()) {- // Cocoa can only be run on the primordial thread and exec() doesn't- // check this.- return HSQML_EVLOOP_WRONG_THREAD;- }-#endif-- // Create application object- if (!mApp) {- mApp = new HsQMLManagerApp();- }-- // Save callbacks- mStartCb = startCb;- mJobsCb = jobsCb;- mYieldCb = yieldCb;-- // Setup events- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::StartedLoopEvent),- Qt::HighEventPriority);- QBasicTimer idleTimer;- if (yieldCb) {- idleTimer.start(0, mApp);- }-- // Run loop- int ret = mApp->exec();-- // Remove redundant events- QCoreApplication::removePostedEvents(- mApp, HsQMLManagerApp::RemoveGCLockEvent);-- // Cleanup callbacks- freeFun(startCb);- mStartCb = NULL;- freeFun(jobsCb);- mJobsCb = NULL;- if (yieldCb) {- freeFun(yieldCb);- mYieldCb = NULL;- }-- // Return- if (ret == 0) {- return HSQML_EVLOOP_OK;- }- else {- QCoreApplication::removePostedEvents(- mApp, HsQMLManagerApp::StartedLoopEvent);- return HSQML_EVLOOP_OTHER_ERROR;- }-}--HsQMLManager::EventLoopStatus HsQMLManager::requireEventLoop()-{- QMutexLocker locker(&mLock);- if (mRunCount > 0) {- mRunCount++;- return HSQML_EVLOOP_OK;- }- else {- return HSQML_EVLOOP_NOT_RUNNING;- }-}--void HsQMLManager::releaseEventLoop()-{- QMutexLocker locker(&mLock);- if (--mRunCount == 0) {- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::StopLoopEvent),- Qt::LowEventPriority);- }-}--void HsQMLManager::notifyJobs()-{- QMutexLocker locker(&mLock);- if (mRunCount > 0) {- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::PendingJobsEvent));- }-}--void HsQMLManager::createEngine(const HsQMLEngineConfig& config)-{- Q_ASSERT (mApp);- QMetaObject::invokeMethod(- mApp, "createEngine", Q_ARG(HsQMLEngineConfig, config));-}--void HsQMLManager::setActiveEngine(HsQMLEngine* engine)-{- Q_ASSERT(!mActiveEngine || !engine);- mActiveEngine = engine;-}--HsQMLEngine* HsQMLManager::activeEngine()-{- return mActiveEngine;-}--void HsQMLManager::postObjectEvent(HsQMLObjectEvent* ev)-{- QCoreApplication::postEvent(mApp, ev);-}--HsQMLManagerApp::HsQMLManagerApp()- : mArgC(1)- , mArg0(0)- , mArgV(&mArg0)- , mApp(mArgC, &mArgV)-{- mApp.setQuitOnLastWindowClosed(false);-}--HsQMLManagerApp::~HsQMLManagerApp()-{}--void HsQMLManagerApp::customEvent(QEvent* ev)-{- switch (ev->type()) {- case HsQMLManagerApp::StartedLoopEvent: {- gManager->mRunning = true;- gManager->mRunCount++;- gManager->mLock.unlock();- gManager->mStartCb();- gManager->mJobsCb();- break;}- case HsQMLManagerApp::StopLoopEvent: {- gManager->mLock.lock();- const QObjectList& cs = gManager->mApp->children();- while (!cs.empty()) {- delete cs.front();- }- gManager->mRunning = false;- gManager->mApp->mApp.quit();- break;}- case HsQMLManagerApp::PendingJobsEvent: {- gManager->mJobsCb();- break;}- case HsQMLManagerApp::RemoveGCLockEvent: {- static_cast<HsQMLObjectEvent*>(ev)->process();- break;}- }-}--void HsQMLManagerApp::timerEvent(QTimerEvent*)-{- Q_ASSERT(gManager->mYieldCb);- gManager->mYieldCb();-}--void HsQMLManagerApp::createEngine(HsQMLEngineConfig config)-{- HsQMLEngine* engine = new HsQMLEngine(config);- engine->setParent(this);-}--int HsQMLManagerApp::exec()-{- return mApp.exec();-}--extern "C" void hsqml_init(- void (*freeFun)(HsFunPtr),- void (*freeStable)(HsStablePtr))-{- if (gManager == NULL) {- HsQMLManager* manager = new HsQMLManager(freeFun, freeStable);- if (!gManager.testAndSetOrdered(NULL, manager)) {- delete manager;- }- }-}--extern "C" HsQMLEventLoopStatus hsqml_evloop_run(- HsQMLTrivialCb startCb,- HsQMLTrivialCb jobsCb,- HsQMLTrivialCb yieldCb)-{- return gManager->runEventLoop(startCb, jobsCb, yieldCb);-}--extern "C" HsQMLEventLoopStatus hsqml_evloop_require()-{- return gManager->requireEventLoop();-}--extern "C" void hsqml_evloop_release()-{- gManager->releaseEventLoop();-}--extern "C" void hsqml_evloop_notify_jobs()-{- gManager->notifyJobs();-}--extern "C" void hsqml_set_debug_loglevel(int ll)-{- Q_ASSERT (gManager);- gManager->setLogLevel(ll);-}
− cbits/HsQMLManager.h
@@ -1,109 +0,0 @@-#ifndef HSQML_MANAGER_H-#define HSQML_MANAGER_H--#include <QtCore/QAtomicPointer>-#include <QtCore/QAtomicInt>-#include <QtCore/QMutex>-#include <QtCore/QString>-#include <QtGui/QApplication>--#include "hsqml.h"-#include "HsQMLEngine.h"--#define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg)--class HsQMLManagerApp;-class HsQMLObjectEvent;--class HsQMLManager-{-public:- enum CounterId {- ClassCount,- ObjectCount,- QObjectCount,- ClassSerial,- ObjectSerial,- TotalCounters- }; -- HsQMLManager(- void (*)(HsFunPtr),- void (*)(HsStablePtr));- void setLogLevel(int);- bool checkLogLevel(int);- void log(const QString&);- int updateCounter(CounterId, int);- void freeFun(HsFunPtr);- void freeStable(HsStablePtr);- bool isEventThread();- typedef HsQMLEventLoopStatus EventLoopStatus;- EventLoopStatus runEventLoop(- HsQMLTrivialCb, HsQMLTrivialCb, HsQMLTrivialCb);- EventLoopStatus requireEventLoop();- void releaseEventLoop();- void notifyJobs();- void createEngine(const HsQMLEngineConfig&);- void setActiveEngine(HsQMLEngine*);- HsQMLEngine* activeEngine();- void postObjectEvent(HsQMLObjectEvent*);--private:- friend class HsQMLManagerApp;- Q_DISABLE_COPY(HsQMLManager)-- int mLogLevel;- QAtomicInt mCounters[TotalCounters];- bool mAtExit;- void (*mFreeFun)(HsFunPtr);- void (*mFreeStable)(HsStablePtr);- HsQMLManagerApp* mApp;- QMutex mLock;- bool mRunning;- int mRunCount;- HsQMLTrivialCb mStartCb;- HsQMLTrivialCb mJobsCb;- HsQMLTrivialCb mYieldCb;- HsQMLEngine* mActiveEngine;-};--class HsQMLManagerApp : public QObject-{- Q_OBJECT--public:- HsQMLManagerApp();- virtual ~HsQMLManagerApp();- virtual void customEvent(QEvent*);- virtual void timerEvent(QTimerEvent*);- Q_SLOT void createEngine(HsQMLEngineConfig);- int exec();-- enum CustomEventIndicies {- StartedLoopEventIndex,- StopLoopEventIndex,- PendingJobsEventIndex,- RemoveGCLockEventIndex- };-- static const QEvent::Type StartedLoopEvent =- static_cast<QEvent::Type>(QEvent::User+StartedLoopEventIndex);- static const QEvent::Type StopLoopEvent =- static_cast<QEvent::Type>(QEvent::User+StopLoopEventIndex);- static const QEvent::Type PendingJobsEvent =- static_cast<QEvent::Type>(QEvent::User+PendingJobsEventIndex);- static const QEvent::Type RemoveGCLockEvent =- static_cast<QEvent::Type>(QEvent::User+RemoveGCLockEventIndex);--private:- Q_DISABLE_COPY(HsQMLManagerApp)-- int mArgC;- char mArg0;- char* mArgV;- QApplication mApp;-};--extern QAtomicPointer<HsQMLManager> gManager;--#endif /*HSQML_MANAGER_H*/
− cbits/HsQMLObject.cpp
@@ -1,329 +0,0 @@-#include <HsFFI.h>-#include <QtCore/QString>-#include <QtDeclarative/QDeclarativeEngine>--#include "HsQMLObject.h"-#include "HsQMLClass.h"-#include "HsQMLManager.h"--static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event"};--HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)- : mHaskell(haskell)- , mKlass(klass)- , mSerial(gManager->updateCounter(HsQMLManager::ObjectSerial, 1))- , mObject(NULL)- , mRefCount(0)-{- ref(Handle);- mKlass->ref(HsQMLClass::ObjProxy);- gManager->updateCounter(HsQMLManager::ObjectCount, 1);-}--HsQMLObjectProxy::~HsQMLObjectProxy()-{- mKlass->deref(HsQMLClass::ObjProxy);- gManager->updateCounter(HsQMLManager::ObjectCount, -1);-}--HsStablePtr HsQMLObjectProxy::haskell() const-{- return mHaskell;-}--HsQMLClass* HsQMLObjectProxy::klass() const-{- return mKlass;-}--HsQMLObject* HsQMLObjectProxy::object(HsQMLEngine* engine)-{- Q_ASSERT(gManager->isEventThread());- Q_ASSERT(engine);- if (!mObject) {- mObject = new HsQMLObject(this, engine);- tryGCLock();-- HSQML_LOG(5,- QString().sprintf("New QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }- return mObject;-}--void HsQMLObjectProxy::clearObject()-{- Q_ASSERT(gManager->isEventThread());-- mObject = NULL;-- HSQML_LOG(5,- QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));-}--void HsQMLObjectProxy::tryGCLock()-{- Q_ASSERT(gManager->isEventThread());-- if (mObject && mHndlCount > 0 && !mObject->isGCLocked()) {- mObject->setGCLock();-- HSQML_LOG(5,- QString().sprintf("Lock QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }-}--void HsQMLObjectProxy::removeGCLock()-{- Q_ASSERT(gManager->isEventThread());-- if (mObject && mHndlCount == 0 && mObject->isGCLocked()) {- mObject->clearGCLock();-- HSQML_LOG(5,- QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }-}--HsQMLEngine* HsQMLObjectProxy::engine() const-{- if (mObject != NULL) {- return mObject->engine();- }- return NULL;-}--void HsQMLObjectProxy::ref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(1);-- HSQML_LOG(count == 0 ? 3 : 4,- QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",- count ? "Ref" : "New", mKlass->name(),- mSerial, cRefSrcNames[src], count+1));-- if (src == Handle) {- mHndlCount.fetchAndAddOrdered(1);- }-}--void HsQMLObjectProxy::deref(RefSrc src)-{- // Remove JavaScript GC lock when there are no handles- if (src == Handle) {- int hndlCount = mHndlCount.fetchAndAddOrdered(-1);- if (hndlCount == 1 && mObject) {- // This will increment the reference count for the lifetime of the- // of the event.- gManager->postObjectEvent(new HsQMLObjectEvent(this));- }- }-- int count = mRefCount.fetchAndAddOrdered(-1);-- HSQML_LOG(count == 1 ? 3 : 4,- QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",- count > 1 ? "Deref" : "Delete", mKlass->name(),- mSerial, cRefSrcNames[src], count));-- if (count == 1) {- delete this;- }-}--HsQMLObjectEvent::HsQMLObjectEvent(HsQMLObjectProxy* proxy)- : QEvent(HsQMLManagerApp::RemoveGCLockEvent)- , mProxy(proxy)-{- mProxy->ref(HsQMLObjectProxy::Event);-}--HsQMLObjectEvent::~HsQMLObjectEvent()-{- mProxy->deref(HsQMLObjectProxy::Event);-}--void HsQMLObjectEvent::process()-{- Q_ASSERT(type() == HsQMLManagerApp::RemoveGCLockEvent);- mProxy->removeGCLock();-}--HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy, HsQMLEngine* engine)- : mProxy(proxy)- , mHaskell(proxy->haskell())- , mKlass(proxy->klass())- , mEngine(engine)-{- QDeclarativeEngine::setObjectOwnership(- this, QDeclarativeEngine::JavaScriptOwnership);- mProxy->ref(HsQMLObjectProxy::Object);- gManager->updateCounter(HsQMLManager::QObjectCount, 1);-}--HsQMLObject::~HsQMLObject()-{- mProxy->clearObject();- mProxy->deref(HsQMLObjectProxy::Object);- gManager->updateCounter(HsQMLManager::QObjectCount, -1);-}--const QMetaObject* HsQMLObject::metaObject() const-{- return QObject::d_ptr->metaObject ?- QObject::d_ptr->metaObject : mKlass->metaObj();-}--void* HsQMLObject::qt_metacast(const char* clname)-{- if (!clname) {- return 0;- }- if (!strcmp(clname, mKlass->metaObj()->className())) {- return static_cast<void*>(const_cast<HsQMLObject*>(this));- }- return QObject::qt_metacast(clname);-}--int HsQMLObject::qt_metacall(QMetaObject::Call c, int id, void** a)-{- id = QObject::qt_metacall(c, id, a);- if (id < 0) {- return id;- }- gManager->setActiveEngine(mEngine);- if (QMetaObject::InvokeMetaMethod == c) {- mKlass->methods()[id](this, a);- id -= mKlass->methodCount();- }- else if (QMetaObject::ReadProperty == c) {- mKlass->properties()[2*id](this, a);- id -= mKlass->propertyCount();- }- else if (QMetaObject::WriteProperty == c) {- HsQMLUniformFunc uf = mKlass->properties()[2*id+1];- if (uf) {- uf(this, a);- }- id -= mKlass->propertyCount();- }- else if (QMetaObject::QueryPropertyDesignable == c ||- QMetaObject::QueryPropertyScriptable == c ||- QMetaObject::QueryPropertyStored == c ||- QMetaObject::QueryPropertyEditable == c ||- QMetaObject::QueryPropertyUser == c) {- id -= mKlass->propertyCount();- }- gManager->setActiveEngine(NULL);- return id;-}--void HsQMLObject::setGCLock()-{- mGCLock = mEngine->scriptEngine()->newQObject(- this, QScriptEngine::ScriptOwnership);-}--void HsQMLObject::clearGCLock()-{- mGCLock = QScriptValue();-}--bool HsQMLObject::isGCLocked() const-{- return mGCLock.isValid();-}--HsQMLObjectProxy* HsQMLObject::proxy() const-{- return mProxy;-}--HsQMLEngine* HsQMLObject::engine() const-{- return mEngine;-}--extern "C" HsQMLObjectHandle* hsqml_create_object(- HsStablePtr haskell, HsQMLClassHandle* kHndl)-{- HsQMLObjectProxy* proxy = new HsQMLObjectProxy(haskell, (HsQMLClass*)kHndl);- return (HsQMLObjectHandle*)proxy;-}--extern "C" void hsqml_object_set_active(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- if (proxy) {- gManager->setActiveEngine(proxy->engine());- }- else {- gManager->setActiveEngine(NULL);- }-}--extern "C" HsStablePtr hsqml_object_get_hs_typerep(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return proxy->klass()->hsTypeRep();-}--extern HsStablePtr hsqml_object_get_haskell(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return proxy->haskell();-}--extern void* hsqml_object_get_pointer(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return (void*)proxy->object(gManager->activeEngine());-}--extern HsQMLObjectHandle* hsqml_get_object_handle(- void* ptr)-{- // Return NULL if the input pointer is NULL- if (!ptr) {- return NULL;- }-- // Get object proxy- HsQMLObject* object = (HsQMLObject*)ptr;- HsQMLObjectProxy* proxy = object->proxy();- proxy->ref(HsQMLObjectProxy::Handle);- proxy->tryGCLock();-- return (HsQMLObjectHandle*)proxy;-}--extern void hsqml_finalise_object_handle(- HsQMLObjectHandle* hndl)-{- if (hndl) {- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- proxy->deref(HsQMLObjectProxy::Handle);- }-}--extern void hsqml_fire_signal(- HsQMLObjectHandle* hndl, int idx, void** args)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- HsQMLEngine* engine = proxy->engine();- // Ignore objects which haven't been marshalled as they are not connected.- if (engine) {- // Clear active engine in case the slot code calls back into Haskell.- Q_ASSERT(gManager->activeEngine() == engine);- gManager->setActiveEngine(NULL);- HsQMLObject* obj = proxy->object(engine);- QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args);- }-}
− cbits/HsQMLObject.h
@@ -1,71 +0,0 @@-#ifndef HSQML_OBJECT_H-#define HSQML_OBJECT_H--#include <QtCore/QObject>-#include <QtCore/QAtomicInt>-#include <QtCore/QEvent>-#include <QtScript/QScriptValue>--class HsQMLEngine;-class HsQMLClass;-class HsQMLObject;--class HsQMLObjectProxy-{-public:- HsQMLObjectProxy(HsStablePtr, HsQMLClass*);- virtual ~HsQMLObjectProxy();- HsStablePtr haskell() const;- HsQMLClass* klass() const;- HsQMLObject* object(HsQMLEngine*);- void clearObject();- void tryGCLock();- void removeGCLock();- HsQMLEngine* engine() const;- enum RefSrc {Handle, Object, Event};- void ref(RefSrc);- void deref(RefSrc);--private:- HsStablePtr mHaskell;- HsQMLClass* mKlass;- int mSerial;- HsQMLObject* volatile mObject;- QAtomicInt mRefCount;- QAtomicInt mHndlCount;-};--class HsQMLObjectEvent : public QEvent-{-public:- HsQMLObjectEvent(HsQMLObjectProxy*);- virtual ~HsQMLObjectEvent();- void process();--private:- HsQMLObjectProxy* mProxy;-};--class HsQMLObject : public QObject-{-public:- HsQMLObject(HsQMLObjectProxy*, HsQMLEngine*);- virtual ~HsQMLObject();- virtual const QMetaObject* metaObject() const;- virtual void* qt_metacast(const char*);- virtual int qt_metacall(QMetaObject::Call, int, void**);- void setGCLock();- void clearGCLock();- bool isGCLocked() const;- HsQMLObjectProxy* proxy() const;- HsQMLEngine* engine() const;--private:- HsQMLObjectProxy* mProxy;- HsStablePtr mHaskell;- HsQMLClass* mKlass;- HsQMLEngine* mEngine;- QScriptValue mGCLock;-};--#endif /*HSQML_OBJECT_H*/
− cbits/HsQMLWindow.cpp
@@ -1,107 +0,0 @@-#include "hsqml.h"-#include "HsQMLManager.h"-#include "HsQMLWindow.h"--HsQMLWindow::HsQMLWindow(HsQMLEngine* engine)- : QObject(engine)- , mEngine(engine)- , mContext(engine->declEngine())- , mView(&mScene)- , mComponent(NULL)-{- // Setup context- mContext.setContextProperty("window", this);-- // Handle Window close event manually- mWindow.setAttribute(Qt::WA_DeleteOnClose, false);- mWindow.installEventFilter(this);-- // Setup for QML performance- mView.setOptimizationFlags(QGraphicsView::DontSavePainterState);- mView.setViewportUpdateMode(QGraphicsView::BoundingRectViewportUpdate);- mScene.setItemIndexMethod(QGraphicsScene::NoIndex);-- // Setup for QML key handling- mView.viewport()->setFocusPolicy(Qt::NoFocus);- mView.setFocusPolicy(Qt::StrongFocus);- mScene.setStickyFocus(true);-- mWindow.setCentralWidget(&mView);-}--HsQMLWindow::~HsQMLWindow()-{-}--bool HsQMLWindow::eventFilter(QObject* obj, QEvent* ev)-{- if (obj == &mWindow && ev->type() == QEvent::Close) {- deleteLater();- }- return false;-}--QUrl HsQMLWindow::source() const-{- return mSource;-}--void HsQMLWindow::setSource(const QUrl& url)-{- mSource = url;- if (mComponent) {- delete mComponent;- mComponent = NULL;- }- if (!mSource.isEmpty()) {- mComponent = new QDeclarativeComponent(- mEngine->declEngine(), mSource, this);- if (mComponent->isLoading()) {- QObject::connect(- mComponent,- SIGNAL(statusChanged(QDeclarativeComponent::Status)),- this,- SLOT(completeSetSource()));- }- else {- completeSetSource();- }- }-}--void HsQMLWindow::completeSetSource()-{- QObject::disconnect(- mComponent, SIGNAL(statusChanged(QDeclarativeComponent::Status)),- this, SLOT(completeSetSource()));- QDeclarativeItem* item =- qobject_cast<QDeclarativeItem*>(mComponent->create(&mContext));- if (item) {- mScene.addItem(item);- }-}--QString HsQMLWindow::title() const-{- return mWindow.windowTitle();-}--void HsQMLWindow::setTitle(const QString& title)-{- mWindow.setWindowTitle(title);-}--bool HsQMLWindow::visible() const-{- return mWindow.isVisible();-}--void HsQMLWindow::setVisible(bool visible)-{- mWindow.setVisible(visible);-}--void HsQMLWindow::close()-{- deleteLater();-}
− cbits/HsQMLWindow.h
@@ -1,45 +0,0 @@-#ifndef HSQML_WINDOW_H-#define HSQML_WINDOW_H--#include <QtCore/QUrl>-#include <QtGui/QMainWindow>-#include <QtGui/QGraphicsScene>-#include <QtGui/QGraphicsView>-#include <QtDeclarative/QDeclarativeContext>-#include <QtDeclarative/QDeclarativeItem>--#include "HsQMLManager.h"--class QDeclarativeComponent;--class HsQMLWindow : public QObject-{- Q_OBJECT--public:- HsQMLWindow(HsQMLEngine*);- virtual ~HsQMLWindow();- virtual bool eventFilter(QObject*, QEvent*);- QUrl source() const;- void setSource(const QUrl&);- Q_PROPERTY(QUrl source READ source WRITE setSource);- QString title() const;- void setTitle(const QString&);- Q_PROPERTY(QString title READ title WRITE setTitle);- bool visible() const;- void setVisible(bool);- Q_PROPERTY(bool visible READ visible WRITE setVisible);- Q_SCRIPTABLE void close();--private:- Q_SLOT void completeSetSource();- HsQMLEngine* mEngine;- QDeclarativeContext mContext;- QMainWindow mWindow;- QGraphicsScene mScene;- QGraphicsView mView;- QUrl mSource;- QDeclarativeComponent* mComponent;-};--#endif /*HSQML_WINDOW_H*/
+ cbits/Intrinsics.cpp view
@@ -0,0 +1,169 @@+#include <QtCore/QString>+#include <QtCore/QMetaType>+#include <QtQml/QJSValue>++#include "Manager.h"++/* String */+extern "C" size_t hsqml_get_string_size()+{+ return sizeof(QString);+}++extern "C" void hsqml_init_string(HsQMLStringHandle* hndl)+{+ new((void*)hndl) QString();+}++extern "C" void hsqml_deinit_string(HsQMLStringHandle* hndl)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ string->~QString();+}++extern "C" UTF16* hsqml_write_string(+ int bufLen, HsQMLStringHandle* hndl)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ string->resize(bufLen);+ return reinterpret_cast<UTF16*>(string->data());+}++extern "C" int hsqml_read_string(+ HsQMLStringHandle* hndl, UTF16** bufPtr)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ *bufPtr = reinterpret_cast<UTF16*>(string->data());+ return string->length();+}++/* JSValue */+extern "C" size_t hsqml_get_jval_size()+{+ return sizeof(QJSValue);+}++extern "C" int hsqml_get_jval_typeid()+{+ return qMetaTypeId<QJSValue>();+}++extern "C" void hsqml_init_jval_null(HsQMLJValHandle* hndl, int undef)+{+ new((void*)hndl) QJSValue(undef ?+ QJSValue::UndefinedValue : QJSValue::NullValue);+}++extern "C" void hsqml_set_jval(HsQMLJValHandle* hndl, HsQMLJValHandle* srch)+{+ QJSValue* dstValue = reinterpret_cast<QJSValue*>(hndl);+ QJSValue* srcValue = reinterpret_cast<QJSValue*>(srch);+ *dstValue = *srcValue;+}++extern "C" void hsqml_deinit_jval(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ value->~QJSValue();+}+++extern "C" void hsqml_init_jval_bool(HsQMLJValHandle* hndl, int b)+{+ new((void*)hndl) QJSValue((bool)b);+}++extern "C" int hsqml_is_jval_bool(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isBool();+}++extern "C" int hsqml_get_jval_bool(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toBool();+}++extern "C" void hsqml_init_jval_int(HsQMLJValHandle* hndl, int i)+{+ new((void*)hndl) QJSValue((int)i);+}++extern "C" void hsqml_init_jval_double(HsQMLJValHandle* hndl, double f)+{+ new((void*)hndl) QJSValue((double)f);+}++extern "C" int hsqml_is_jval_number(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isNumber();+}++extern "C" int hsqml_get_jval_int(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toInt();+}++extern "C" double hsqml_get_jval_double(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toNumber();+}++extern "C" void hsqml_init_jval_string(+ HsQMLJValHandle* hndl, HsQMLStringHandle* strh)+{+ QString* string = reinterpret_cast<QString*>(strh);+ new((void*)hndl) QJSValue(*string);+}+extern "C" int hsqml_is_jval_string(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isString();+}++extern "C" void hsqml_get_jval_string(+ HsQMLJValHandle* hndl, HsQMLStringHandle* strh)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ QString* string = reinterpret_cast<QString*>(strh);+ *string = value->toString();+}++/* Array */+extern "C" void hsqml_init_jval_array(HsQMLJValHandle* hndl, unsigned int len)+{+ new((void*)hndl) QJSValue(+ gManager->activeEngine()->declEngine()->newArray(len));+}++extern "C" int hsqml_is_jval_array(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isArray();+}++extern "C" unsigned int hsqml_get_jval_array_length(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->property("length").toUInt();+}++extern "C" void hsqml_jval_array_get(+ HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl)+{+ QJSValue* array = reinterpret_cast<QJSValue*>(ahndl);+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ *value = array->property(i);+}++extern "C" void hsqml_jval_array_set(+ HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl)+{+ QJSValue* array = reinterpret_cast<QJSValue*>(ahndl);+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ array->setProperty(i, *value);+}
+ cbits/Manager.cpp view
@@ -0,0 +1,325 @@+#include <iostream>+#include <cstdlib>+#include <QtCore/QBasicTimer>+#include <QtCore/QMetaType>+#include <QtCore/QMutexLocker>+#include <QtCore/QThread>+#ifdef Q_OS_MAC+#include <pthread.h>+#endif++#include "Manager.h"+#include "Object.h"++static const char* cCounterNames[] = {+ "ClassCounter",+ "ObjectCounter",+ "QObjectCounter",+ "ClassSerial",+ "ObjectSerial"+};++extern "C" void hsqml_dump_counters()+{+ Q_ASSERT (gManager);+ if (gManager->checkLogLevel(1)) {+ for (int i=0; i<HsQMLManager::TotalCounters; i++) {+ gManager->log(QString().sprintf("%s = %d.",+ cCounterNames[i], gManager->updateCounter(+ static_cast<HsQMLManager::CounterId>(i), 0)));+ }+ }+}++ManagerPointer gManager;++HsQMLManager::HsQMLManager(+ void (*freeFun)(HsFunPtr),+ void (*freeStable)(HsStablePtr))+ : mLogLevel(0)+ , mAtExit(false)+ , mFreeFun(freeFun)+ , mFreeStable(freeStable)+ , mApp(NULL)+ , mLock(QMutex::Recursive)+ , mRunning(false)+ , mRunCount(0)+ , mStartCb(NULL)+ , mJobsCb(NULL)+ , mYieldCb(NULL)+ , mActiveEngine(NULL)+{+ qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");++ const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL");+ if (env) {+ setLogLevel(QString(env).toInt());+ }+}++void HsQMLManager::setLogLevel(int ll)+{+ mLogLevel = ll;+ if (ll > 0 && !mAtExit) {+ if (atexit(&hsqml_dump_counters) == 0) {+ mAtExit = true;+ }+ else {+ log("Failed to register callback with atexit().");+ }+ }+}++bool HsQMLManager::checkLogLevel(int ll)+{+ return mLogLevel >= ll;+}++void HsQMLManager::log(const QString& msg)+{+ std::cerr << "HsQML: " << msg.toStdString() << std::endl;+}++int HsQMLManager::updateCounter(CounterId id, int delta)+{+ return mCounters[id].fetchAndAddRelaxed(delta);+}++void HsQMLManager::freeFun(HsFunPtr funPtr)+{+ mFreeFun(funPtr);+}++void HsQMLManager::freeStable(HsStablePtr stablePtr)+{+ mFreeStable(stablePtr);+}++bool HsQMLManager::isEventThread()+{+ return mApp && mApp->thread() == QThread::currentThread();+}++HsQMLManager::EventLoopStatus HsQMLManager::runEventLoop(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb)+{+ QMutexLocker locker(&mLock);++ // Check if already running+ if (mRunning) {+ return HSQML_EVLOOP_ALREADY_RUNNING;+ }++ // Check if event loop bound to a different thread+ if (mApp && !isEventThread()) {+ return HSQML_EVLOOP_WRONG_THREAD;+ }++#ifdef Q_OS_MAC+ if (!pthread_main_np()) {+ // Cocoa can only be run on the primordial thread and exec() doesn't+ // check this.+ return HSQML_EVLOOP_WRONG_THREAD;+ }+#endif++ // Create application object+ if (!mApp) {+ mApp = new HsQMLManagerApp();+ }++ // Save callbacks+ mStartCb = startCb;+ mJobsCb = jobsCb;+ mYieldCb = yieldCb;++ // Setup events+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StartedLoopEvent),+ Qt::HighEventPriority);+ QBasicTimer idleTimer;+ if (yieldCb) {+ idleTimer.start(0, mApp);+ }++ // Run loop+ int ret = mApp->exec();++ // Remove redundant events+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::RemoveGCLockEvent);++ // Cleanup callbacks+ freeFun(startCb);+ mStartCb = NULL;+ freeFun(jobsCb);+ mJobsCb = NULL;+ if (yieldCb) {+ freeFun(yieldCb);+ mYieldCb = NULL;+ }++ // Return+ if (ret == 0) {+ return HSQML_EVLOOP_OK;+ }+ else {+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::StartedLoopEvent);+ return HSQML_EVLOOP_OTHER_ERROR;+ }+}++HsQMLManager::EventLoopStatus HsQMLManager::requireEventLoop()+{+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ mRunCount++;+ return HSQML_EVLOOP_OK;+ }+ else {+ return HSQML_EVLOOP_NOT_RUNNING;+ }+}++void HsQMLManager::releaseEventLoop()+{+ QMutexLocker locker(&mLock);+ if (--mRunCount == 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StopLoopEvent),+ Qt::LowEventPriority);+ }+}++void HsQMLManager::notifyJobs()+{+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::PendingJobsEvent));+ }+}++void HsQMLManager::createEngine(const HsQMLEngineConfig& config)+{+ Q_ASSERT (mApp);+ QMetaObject::invokeMethod(+ mApp, "createEngine", Q_ARG(HsQMLEngineConfig, config));+}++void HsQMLManager::setActiveEngine(HsQMLEngine* engine)+{+ Q_ASSERT(!mActiveEngine || !engine);+ mActiveEngine = engine;+}++HsQMLEngine* HsQMLManager::activeEngine()+{+ return mActiveEngine;+}++void HsQMLManager::postObjectEvent(HsQMLObjectEvent* ev)+{+ QCoreApplication::postEvent(mApp, ev);+}++HsQMLManagerApp::HsQMLManagerApp()+ : mArgC(1)+ , mArg0(0)+ , mArgV(&mArg0)+ , mApp(mArgC, &mArgV)+{+ mApp.setQuitOnLastWindowClosed(false);+}++HsQMLManagerApp::~HsQMLManagerApp()+{}++void HsQMLManagerApp::customEvent(QEvent* ev)+{+ switch (ev->type()) {+ case HsQMLManagerApp::StartedLoopEvent: {+ gManager->mRunning = true;+ gManager->mRunCount++;+ gManager->mLock.unlock();+ gManager->mStartCb();+ gManager->mJobsCb();+ break;}+ case HsQMLManagerApp::StopLoopEvent: {+ gManager->mLock.lock();+ const QObjectList& cs = gManager->mApp->children();+ while (!cs.empty()) {+ delete cs.front();+ }+ gManager->mRunning = false;+ gManager->mApp->mApp.quit();+ break;}+ case HsQMLManagerApp::PendingJobsEvent: {+ gManager->mJobsCb();+ break;}+ case HsQMLManagerApp::RemoveGCLockEvent: {+ static_cast<HsQMLObjectEvent*>(ev)->process();+ break;}+ }+}++void HsQMLManagerApp::timerEvent(QTimerEvent*)+{+ Q_ASSERT(gManager->mYieldCb);+ gManager->mYieldCb();+}++void HsQMLManagerApp::createEngine(HsQMLEngineConfig config)+{+ HsQMLEngine* engine = new HsQMLEngine(config);+ engine->setParent(this);+}++int HsQMLManagerApp::exec()+{+ return mApp.exec();+}++extern "C" void hsqml_init(+ void (*freeFun)(HsFunPtr),+ void (*freeStable)(HsStablePtr))+{+ if (gManager == NULL) {+ HsQMLManager* manager = new HsQMLManager(freeFun, freeStable);+ if (!gManager.testAndSetOrdered(NULL, manager)) {+ delete manager;+ }+ }+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_run(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb)+{+ return gManager->runEventLoop(startCb, jobsCb, yieldCb);+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_require()+{+ return gManager->requireEventLoop();+}++extern "C" void hsqml_evloop_release()+{+ gManager->releaseEventLoop();+}++extern "C" void hsqml_evloop_notify_jobs()+{+ gManager->notifyJobs();+}++extern "C" void hsqml_set_debug_loglevel(int ll)+{+ Q_ASSERT (gManager);+ gManager->setLogLevel(ll);+}
+ cbits/Manager.h view
@@ -0,0 +1,123 @@+#ifndef HSQML_MANAGER_H+#define HSQML_MANAGER_H++#include <QtCore/QAtomicPointer>+#include <QtCore/QAtomicInt>+#include <QtCore/QMutex>+#include <QtCore/QString>+#include <QtWidgets/QApplication>++#include "hsqml.h"+#include "Engine.h"++#define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg)++class HsQMLManagerApp;+class HsQMLObjectEvent;++class HsQMLManager+{+public:+ enum CounterId {+ ClassCount,+ ObjectCount,+ QObjectCount,+ ClassSerial,+ ObjectSerial,+ TotalCounters+ }; ++ HsQMLManager(+ void (*)(HsFunPtr),+ void (*)(HsStablePtr));+ void setLogLevel(int);+ bool checkLogLevel(int);+ void log(const QString&);+ int updateCounter(CounterId, int);+ void freeFun(HsFunPtr);+ void freeStable(HsStablePtr);+ bool isEventThread();+ typedef HsQMLEventLoopStatus EventLoopStatus;+ EventLoopStatus runEventLoop(+ HsQMLTrivialCb, HsQMLTrivialCb, HsQMLTrivialCb);+ EventLoopStatus requireEventLoop();+ void releaseEventLoop();+ void notifyJobs();+ void createEngine(const HsQMLEngineConfig&);+ void setActiveEngine(HsQMLEngine*);+ HsQMLEngine* activeEngine();+ void postObjectEvent(HsQMLObjectEvent*);++private:+ friend class HsQMLManagerApp;+ Q_DISABLE_COPY(HsQMLManager)++ int mLogLevel;+ QAtomicInt mCounters[TotalCounters];+ bool mAtExit;+ void (*mFreeFun)(HsFunPtr);+ void (*mFreeStable)(HsStablePtr);+ HsQMLManagerApp* mApp;+ QMutex mLock;+ bool mRunning;+ int mRunCount;+ HsQMLTrivialCb mStartCb;+ HsQMLTrivialCb mJobsCb;+ HsQMLTrivialCb mYieldCb;+ HsQMLEngine* mActiveEngine;+};++class HsQMLManagerApp : public QObject+{+ Q_OBJECT++public:+ HsQMLManagerApp();+ virtual ~HsQMLManagerApp();+ virtual void customEvent(QEvent*);+ virtual void timerEvent(QTimerEvent*);+ Q_SLOT void createEngine(HsQMLEngineConfig);+ int exec();++ enum CustomEventIndicies {+ StartedLoopEventIndex,+ StopLoopEventIndex,+ PendingJobsEventIndex,+ RemoveGCLockEventIndex+ };++ static const QEvent::Type StartedLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StartedLoopEventIndex);+ static const QEvent::Type StopLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StopLoopEventIndex);+ static const QEvent::Type PendingJobsEvent =+ static_cast<QEvent::Type>(QEvent::User+PendingJobsEventIndex);+ static const QEvent::Type RemoveGCLockEvent =+ static_cast<QEvent::Type>(QEvent::User+RemoveGCLockEventIndex);++private:+ Q_DISABLE_COPY(HsQMLManagerApp)++ int mArgC;+ char mArg0;+ char* mArgV;+ QApplication mApp;+};++class ManagerPointer : public QAtomicPointer<HsQMLManager>+{+public:+ HsQMLManager* operator->() const+ {+ return load();+ }++ operator HsQMLManager*() const+ {+ return load();+ }+};++extern ManagerPointer gManager;++#endif /*HSQML_MANAGER_H*/
+ cbits/Object.cpp view
@@ -0,0 +1,348 @@+#include <HsFFI.h>+#include <QtCore/QString>+#include <QtQml/QQmlEngine>++#include "Object.h"+#include "Class.h"+#include "Manager.h"++static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event"};++HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)+ : mHaskell(haskell)+ , mKlass(klass)+ , mSerial(gManager->updateCounter(HsQMLManager::ObjectSerial, 1))+ , mObject(NULL)+ , mRefCount(0)+{+ ref(Handle);+ mKlass->ref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, 1);+}++HsQMLObjectProxy::~HsQMLObjectProxy()+{+ mKlass->deref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, -1);+}++HsStablePtr HsQMLObjectProxy::haskell() const+{+ return mHaskell;+}++HsQMLClass* HsQMLObjectProxy::klass() const+{+ return mKlass;+}++HsQMLObject* HsQMLObjectProxy::object(HsQMLEngine* engine)+{+ Q_ASSERT(gManager->isEventThread());+ Q_ASSERT(engine);+ if (!mObject) {+ mObject = new HsQMLObject(this, engine);+ tryGCLock();++ HSQML_LOG(5,+ QString().sprintf("New QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+ return mObject;+}++void HsQMLObjectProxy::clearObject()+{+ Q_ASSERT(gManager->isEventThread());++ mObject = NULL;++ HSQML_LOG(5,+ QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+}++void HsQMLObjectProxy::tryGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mHndlCount.loadAcquire() > 0 && !mObject->isGCLocked()) {+ mObject->setGCLock();++ HSQML_LOG(5,+ QString().sprintf("Lock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+}++void HsQMLObjectProxy::removeGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mHndlCount.loadAcquire() == 0 && mObject->isGCLocked()) {+ mObject->clearGCLock();++ HSQML_LOG(5,+ QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+}++HsQMLEngine* HsQMLObjectProxy::engine() const+{+ if (mObject != NULL) {+ return mObject->engine();+ }+ return NULL;+}++void HsQMLObjectProxy::ref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(1);++ HSQML_LOG(count == 0 ? 3 : 4,+ QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count ? "Ref" : "New", mKlass->name(),+ mSerial, cRefSrcNames[src], count+1));++ if (src == Handle) {+ mHndlCount.fetchAndAddOrdered(1);+ }+}++void HsQMLObjectProxy::deref(RefSrc src)+{+ // Remove JavaScript GC lock when there are no handles+ if (src == Handle) {+ int hndlCount = mHndlCount.fetchAndAddOrdered(-1);+ if (hndlCount == 1 && mObject) {+ // This will increment the reference count for the lifetime of the+ // of the event.+ gManager->postObjectEvent(new HsQMLObjectEvent(this));+ }+ }++ int count = mRefCount.fetchAndAddOrdered(-1);++ HSQML_LOG(count == 1 ? 3 : 4,+ QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", mKlass->name(),+ mSerial, cRefSrcNames[src], count));++ if (count == 1) {+ delete this;+ }+}++HsQMLObjectEvent::HsQMLObjectEvent(HsQMLObjectProxy* proxy)+ : QEvent(HsQMLManagerApp::RemoveGCLockEvent)+ , mProxy(proxy)+{+ mProxy->ref(HsQMLObjectProxy::Event);+}++HsQMLObjectEvent::~HsQMLObjectEvent()+{+ mProxy->deref(HsQMLObjectProxy::Event);+}++void HsQMLObjectEvent::process()+{+ Q_ASSERT(type() == HsQMLManagerApp::RemoveGCLockEvent);+ mProxy->removeGCLock();+}++HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy, HsQMLEngine* engine)+ : mProxy(proxy)+ , mHaskell(proxy->haskell())+ , mKlass(proxy->klass())+ , mEngine(engine)+{+ QQmlEngine::setObjectOwnership(+ this, QQmlEngine::JavaScriptOwnership);+ mProxy->ref(HsQMLObjectProxy::Object);+ gManager->updateCounter(HsQMLManager::QObjectCount, 1);+}++HsQMLObject::~HsQMLObject()+{+ mProxy->clearObject();+ mProxy->deref(HsQMLObjectProxy::Object);+ gManager->updateCounter(HsQMLManager::QObjectCount, -1);+}++const QMetaObject* HsQMLObject::metaObject() const+{+ return QObject::d_ptr->metaObject ?+ QObject::d_ptr->dynamicMetaObject() : mKlass->metaObj();+}++void* HsQMLObject::qt_metacast(const char* clname)+{+ if (!clname) {+ return 0;+ }+ if (!strcmp(clname, mKlass->metaObj()->className())) {+ return static_cast<void*>(const_cast<HsQMLObject*>(this));+ }+ return QObject::qt_metacast(clname);+}++int HsQMLObject::qt_metacall(QMetaObject::Call c, int id, void** a)+{+ id = QObject::qt_metacall(c, id, a);+ if (id < 0) {+ return id;+ }+ gManager->setActiveEngine(mEngine);+ if (QMetaObject::InvokeMetaMethod == c) {+ mKlass->methods()[id](this, a);+ id -= mKlass->methodCount();+ }+ else if (QMetaObject::ReadProperty == c) {+ mKlass->properties()[2*id](this, a);+ id -= mKlass->propertyCount();+ }+ else if (QMetaObject::WriteProperty == c) {+ HsQMLUniformFunc uf = mKlass->properties()[2*id+1];+ if (uf) {+ uf(this, a);+ }+ id -= mKlass->propertyCount();+ }+ else if (QMetaObject::QueryPropertyDesignable == c ||+ QMetaObject::QueryPropertyScriptable == c ||+ QMetaObject::QueryPropertyStored == c ||+ QMetaObject::QueryPropertyEditable == c ||+ QMetaObject::QueryPropertyUser == c) {+ id -= mKlass->propertyCount();+ }+ gManager->setActiveEngine(NULL);+ return id;+}++void HsQMLObject::setGCLock()+{+ mGCLock = mEngine->declEngine()->newQObject(this);+}++void HsQMLObject::clearGCLock()+{+ mGCLock = QJSValue(QJSValue::NullValue);+}++bool HsQMLObject::isGCLocked() const+{+ return mGCLock.isQObject();+}++QJSValue* HsQMLObject::gcLockVar()+{+ return &mGCLock;+}++HsQMLObjectProxy* HsQMLObject::proxy() const+{+ return mProxy;+}++HsQMLEngine* HsQMLObject::engine() const+{+ return mEngine;+}++extern "C" HsQMLObjectHandle* hsqml_create_object(+ HsStablePtr haskell, HsQMLClassHandle* kHndl)+{+ HsQMLObjectProxy* proxy = new HsQMLObjectProxy(haskell, (HsQMLClass*)kHndl);+ return (HsQMLObjectHandle*)proxy;+}++extern "C" void hsqml_object_set_active(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ if (proxy) {+ gManager->setActiveEngine(proxy->engine());+ }+ else {+ gManager->setActiveEngine(NULL);+ }+}++extern "C" HsStablePtr hsqml_object_get_hs_typerep(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ return proxy->klass()->hsTypeRep();+}++extern HsStablePtr hsqml_object_get_hs_value(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ return proxy->haskell();+}++extern void* hsqml_object_get_pointer(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+ return (void*)proxy->object(gManager->activeEngine());+}++extern HsQMLJValHandle* hsqml_object_get_jval(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+ HsQMLObject* obj = proxy->object(gManager->activeEngine());+ return reinterpret_cast<HsQMLJValHandle*>(obj->gcLockVar());+}++extern HsQMLObjectHandle* hsqml_get_object_from_pointer(+ void* ptr)+{+ // Return NULL if the input pointer is NULL+ if (!ptr) {+ return NULL;+ }++ // Get object proxy+ HsQMLObject* object = (HsQMLObject*)ptr;+ HsQMLObjectProxy* proxy = object->proxy();+ proxy->ref(HsQMLObjectProxy::Handle);+ proxy->tryGCLock();++ return (HsQMLObjectHandle*)proxy;+}++extern HsQMLObjectHandle* hsqml_get_object_from_jval(+ HsQMLJValHandle* jvalHndl)+{+ QJSValue* jval = reinterpret_cast<QJSValue*>(jvalHndl);+ return hsqml_get_object_from_pointer(jval->toQObject());+}++extern void hsqml_finalise_object_handle(+ HsQMLObjectHandle* hndl)+{+ if (hndl) {+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ proxy->deref(HsQMLObjectProxy::Handle);+ }+}++extern void hsqml_fire_signal(+ HsQMLObjectHandle* hndl, int idx, void** args)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ HsQMLEngine* engine = proxy->engine();+ // Ignore objects which haven't been marshalled as they are not connected.+ if (engine) {+ // Clear active engine in case the slot code calls back into Haskell.+ Q_ASSERT(gManager->activeEngine() == engine);+ gManager->setActiveEngine(NULL);+ HsQMLObject* obj = proxy->object(engine);+ QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args);+ }+}
+ cbits/Object.h view
@@ -0,0 +1,72 @@+#ifndef HSQML_OBJECT_H+#define HSQML_OBJECT_H++#include <QtCore/QObject>+#include <QtCore/QAtomicInt>+#include <QtCore/QEvent>+#include <QtQml/QJSValue>++class HsQMLEngine;+class HsQMLClass;+class HsQMLObject;++class HsQMLObjectProxy+{+public:+ HsQMLObjectProxy(HsStablePtr, HsQMLClass*);+ virtual ~HsQMLObjectProxy();+ HsStablePtr haskell() const;+ HsQMLClass* klass() const;+ HsQMLObject* object(HsQMLEngine*);+ void clearObject();+ void tryGCLock();+ void removeGCLock();+ HsQMLEngine* engine() const;+ enum RefSrc {Handle, Object, Event};+ void ref(RefSrc);+ void deref(RefSrc);++private:+ HsStablePtr mHaskell;+ HsQMLClass* mKlass;+ int mSerial;+ HsQMLObject* volatile mObject;+ QAtomicInt mRefCount;+ QAtomicInt mHndlCount;+};++class HsQMLObjectEvent : public QEvent+{+public:+ HsQMLObjectEvent(HsQMLObjectProxy*);+ virtual ~HsQMLObjectEvent();+ void process();++private:+ HsQMLObjectProxy* mProxy;+};++class HsQMLObject : public QObject+{+public:+ HsQMLObject(HsQMLObjectProxy*, HsQMLEngine*);+ virtual ~HsQMLObject();+ virtual const QMetaObject* metaObject() const;+ virtual void* qt_metacast(const char*);+ virtual int qt_metacall(QMetaObject::Call, int, void**);+ void setGCLock();+ void clearGCLock();+ bool isGCLocked() const;+ QJSValue* gcLockVar();+ HsQMLObjectProxy* proxy() const;+ HsQMLEngine* engine() const;++private:+ HsQMLObjectProxy* mProxy;+ HsStablePtr mHaskell;+ HsQMLClass* mKlass;+ HsQMLEngine* mEngine;+ QJSValue mGCLock;+};++#endif /*HSQML_OBJECT_H*/
cbits/hsqml.h view
@@ -50,29 +50,77 @@ extern void hsqml_deinit_string( HsQMLStringHandle*); -extern UTF16* hsqml_marshal_string(+extern UTF16* hsqml_write_string( int, HsQMLStringHandle*); -extern int hsqml_unmarshal_string(+extern int hsqml_read_string( HsQMLStringHandle*, UTF16**); -/* URL */-typedef char HsQMLUrlHandle;+/* JSValue */+typedef char HsQMLJValHandle; -extern size_t hsqml_get_url_size();+extern size_t hsqml_get_jval_size(); -extern void hsqml_init_url(- HsQMLUrlHandle*);+extern int hsqml_get_jval_typeid(); -extern void hsqml_deinit_url(- HsQMLUrlHandle*);+extern void hsqml_init_jval_null(+ HsQMLJValHandle* hndl, int); -extern void hsqml_marshal_url(- char*, int, HsQMLUrlHandle*);+extern void hsqml_set_jval(+ HsQMLJValHandle*, HsQMLJValHandle*); -extern int hsqml_unmarshal_url(- HsQMLUrlHandle*, char**);+extern void hsqml_deinit_jval(+ HsQMLJValHandle*); +extern void hsqml_init_jval_bool(+ HsQMLJValHandle*, int);++extern int hsqml_is_jval_bool(+ HsQMLJValHandle* hndl);++extern int hsqml_get_jval_bool(+ HsQMLJValHandle* hndl);++extern void hsqml_init_jval_int(+ HsQMLJValHandle*, int);++extern void hsqml_init_jval_double(+ HsQMLJValHandle*, double);++extern int hsqml_is_jval_number(+ HsQMLJValHandle*);++extern int hsqml_get_jval_int(+ HsQMLJValHandle*);++extern double hsqml_get_jval_double(+ HsQMLJValHandle*);++extern void hsqml_init_jval_string(+ HsQMLJValHandle*, HsQMLStringHandle*);++extern int hsqml_is_jval_string(+ HsQMLJValHandle*);++extern void hsqml_get_jval_string(+ HsQMLJValHandle*, HsQMLStringHandle*);++/* Array */+extern void hsqml_init_jval_array(+ HsQMLJValHandle*, unsigned int);++extern int hsqml_is_jval_array(+ HsQMLJValHandle*);++extern unsigned int hsqml_get_jval_array_length(+ HsQMLJValHandle*);++extern void hsqml_jval_array_get(+ HsQMLJValHandle*, unsigned int, HsQMLJValHandle*);++extern void hsqml_jval_array_set(+ HsQMLJValHandle*, unsigned int, HsQMLJValHandle*);+ /* Class */ typedef char HsQMLClassHandle; @@ -81,7 +129,8 @@ extern int hsqml_get_next_class_id(); extern HsQMLClassHandle* hsqml_create_class(- unsigned int*, char*, HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*);+ unsigned int*, unsigned int*, char*,+ HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*); extern void hsqml_finalise_class_handle( HsQMLClassHandle* hndl);@@ -98,15 +147,21 @@ extern HsStablePtr hsqml_object_get_hs_typerep( HsQMLObjectHandle*); -extern HsStablePtr hsqml_object_get_haskell(+extern HsStablePtr hsqml_object_get_hs_value( HsQMLObjectHandle*); extern void* hsqml_object_get_pointer( HsQMLObjectHandle*); -extern HsQMLObjectHandle* hsqml_get_object_handle(+extern HsQMLJValHandle* hsqml_object_get_jval(+ HsQMLObjectHandle*);++extern HsQMLObjectHandle* hsqml_get_object_from_pointer( void*); +extern HsQMLObjectHandle* hsqml_get_object_from_jval(+ HsQMLJValHandle*);+ extern void hsqml_finalise_object_handle( HsQMLObjectHandle*); @@ -116,9 +171,6 @@ /* Engine */ extern void hsqml_create_engine( HsQMLObjectHandle*,- HsQMLUrlHandle*,- int,- int, HsQMLStringHandle*, HsQMLTrivialCb stopCb);
hsqml.cabal view
@@ -1,5 +1,5 @@ Name: hsqml-Version: 0.2.0.3+Version: 0.3.0.0 Cabal-version: >= 1.14 Build-type: Custom License: BSD3@@ -38,7 +38,6 @@ base == 4.*, containers >= 0.4 && < 0.6, filepath == 1.3.*,- network >= 2.3 && < 2.5, text >= 0.11 && < 1.2, tagged >= 0.4 && < 0.8, transformers >= 0.2 && < 0.4@@ -55,34 +54,43 @@ 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/HsQMLClass.cpp- cbits/HsQMLEngine.cpp- cbits/HsQMLIntrinsics.cpp- cbits/HsQMLManager.cpp- cbits/HsQMLObject.cpp- cbits/HsQMLWindow.cpp+ cbits/Class.cpp+ cbits/Engine.cpp+ cbits/Intrinsics.cpp+ cbits/Manager.cpp+ cbits/Object.cpp Include-dirs: cbits X-moc-headers:- cbits/HsQMLEngine.h- cbits/HsQMLManager.h- cbits/HsQMLWindow.h+ cbits/Engine.h+ cbits/Manager.h X-separate-cbits: True Build-tools: c2hs if flag(ForceGHCiLib) X-force-ghci-lib: True if os(windows) && !flag(UsePkgConfig) Include-dirs: /QT_ROOT/include- Extra-libraries: QtCore4, QtGui4, QtScript4, QtDeclarative4, stdc+++ Extra-libraries:+ Qt5Core, Qt5Gui, Qt5Widgets, Qt5Qml, Qt5Quick, stdc++ Extra-lib-dirs: /SYS_ROOT/bin /QT_ROOT/bin+ if impl(ghc < 7.8)+ -- Pre-7.8 GHCi can't load eh_frame sections+ GHC-options: -optc-fno-asynchronous-unwind-tables else if os(darwin) && !flag(UsePkgConfig)- Frameworks: QtCore QtGui QtScript QtDeclarative+ Frameworks: QtCore QtGui QtWidgets QtQml QtQuick+ CC-options: -F /QT_ROOT/lib+ GHC-options: -framework-path /QT_ROOT/lib+ X-framework-dirs: /QT_ROOT/lib else Pkgconfig-depends:- QtScript >= 4.7 && < 5.0, QtDeclarative >= 4.7 && < 5.0+ Qt5Core >= 5.0 && < 6.0,+ Qt5Gui >= 5.0 && < 6.0,+ Qt5Widgets >= 5.0 && < 6.0,+ Qt5Qml >= 5.0 && < 6.0,+ Qt5Quick >= 5.0 && < 6.0 Extra-libraries: stdc++ Test-Suite hsqml-test1@@ -94,11 +102,13 @@ base == 4.*, containers >= 0.4 && < 0.6, directory >= 1.1 && < 1.3,- network >= 2.3 && < 2.5, text >= 0.11 && < 1.2, tagged >= 0.4 && < 0.8,- QuickCheck >= 2.4 && < 2.7,- hsqml == 0.2.*+ QuickCheck >= 2.4 && < 2.8,+ hsqml == 0.3.*+ if os(darwin) && !flag(UsePkgConfig)+ -- Library not registered yet+ GHC-options: -framework-path /QT_ROOT/lib if flag(ThreadedTestSuite) GHC-options: -threaded
src/Graphics/QML.hs view
@@ -16,24 +16,6 @@ The 'Graphics.QML.Objects' module allows you to define your own custom object types which can be marshalled between Haskell and JavaScript. -}--- * Script-side APIs-{-|-The @window@ object provides the following methods and properties to QML-scripts.--/Properties/--[@source : url@] URL for the Window's QML document.--[@title : string@] Window title.--[@visible : bool@] Window visibility.--/Methods/--[@close()@] Closes the window.-- -} -- * Graphics.QML module Graphics.QML.Engine, module Graphics.QML.Marshal,
src/Graphics/QML/Engine.hs view
@@ -7,14 +7,9 @@ -- | Functions for starting QML engines, displaying content in a window. module Graphics.QML.Engine ( -- * Engines- InitialWindowState(- ShowWindow,- ShowWindowWithTitle,- HideWindow), EngineConfig( EngineConfig,- initialURL,- initialWindowState,+ initialDocument, contextObject), defaultEngineConfig, Engine,@@ -29,13 +24,15 @@ requireEventLoop, EventLoopException(), - -- * Utilities- filePathToURI+ -- * Document Paths+ DocumentPath(),+ fileDocument,+ uriDocument ) where import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.BindCore import Graphics.QML.Marshal import Graphics.QML.Objects@@ -46,31 +43,18 @@ 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 as T+import Data.Traversable import Data.Typeable+import Foreign.Ptr import System.FilePath (isAbsolute, splitDirectories, pathSeparators)-import Network.URI (URI(URI), URIAuth(URIAuth), nullURI, uriPath) --- | Specifies the intial state of the display window.-data InitialWindowState- -- | A visible window should be created for the initial document with a- -- default title.- = ShowWindow- -- | A visible window should be created for the initial document with the- -- given title.- | ShowWindowWithTitle String- -- | A window should be created for the initial document, but it will remain- -- hidden until made visible by the QML script.- | HideWindow- -- | Holds parameters for configuring a QML runtime engine. data EngineConfig = EngineConfig {- -- | URL for the first QML document to be loaded.- initialURL :: URI,- -- | Window state for the initial QML document.- initialWindowState :: InitialWindowState,+ -- | Path to the first QML document to be loaded.+ initialDocument :: DocumentPath, -- | Context 'Object' made available to QML script code. contextObject :: Maybe AnyObjRef }@@ -79,20 +63,10 @@ -- working directory into a visible window with no context object. defaultEngineConfig :: EngineConfig defaultEngineConfig = EngineConfig {- initialURL = nullURI {uriPath = "main.qml"},- initialWindowState = ShowWindow,+ initialDocument = DocumentPath "main.qml", contextObject = Nothing } -isWindowShown :: InitialWindowState -> Bool-isWindowShown ShowWindow = True-isWindowShown (ShowWindowWithTitle _) = True-isWindowShown HideWindow = False--getWindowTitle :: InitialWindowState -> Maybe String-getWindowTitle (ShowWindowWithTitle t) = Just t-getWindowTitle _ = Nothing- -- | Represents a QML engine. data Engine = Engine @@ -100,16 +74,10 @@ runEngineImpl config stopCb = do hsqmlInit let obj = contextObject config- url = initialURL config- state = initialWindowState config- showWin = isWindowShown state- maybeTitle = getWindowTitle state- setTitle = isJust maybeTitle- titleStr = fromMaybe "" maybeTitle- hndl <- T.sequence $ fmap mHsToObj $ obj- mHsToAlloc url $ \urlPtr -> do- mHsToAlloc titleStr $ \titlePtr -> do- hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr stopCb+ DocumentPath res = initialDocument config+ hndl <- sequenceA $ fmap mToHndl $ obj+ mWithCVal (T.pack res) $ \resPtr -> do+ hsqmlCreateEngine hndl (HsQMLStringHandle $ castPtr resPtr) stopCb return Engine -- | Starts a new QML engine using the supplied configuration and blocks until@@ -220,9 +188,12 @@ instance Exception EventLoopException --- | Convenience function for converting local file paths into URIs.-filePathToURI :: FilePath -> URI-filePathToURI fp =+-- | Path to a QML document file.+newtype DocumentPath = DocumentPath String++-- | Converts a local file path into a 'DocumentPath'.+fileDocument :: FilePath -> DocumentPath+fileDocument fp = let ds = splitDirectories fp abs = isAbsolute fp fixHead =@@ -232,6 +203,8 @@ mapHead f (x:xs) = f x : xs afp = intercalate "/" $ mapHead fixHead ds rfp = intercalate "/" ds- in if abs- then URI "file:" (Just $ URIAuth "" "" "") afp "" ""- else URI "" Nothing rfp "" ""+ in DocumentPath $ if abs then "file://" ++ afp else rfp++-- | Converts a URI string into a 'DocumentPath'.+uriDocument :: String -> DocumentPath+uriDocument = DocumentPath
src/Graphics/QML/Internal/BindCore.chs view
@@ -5,6 +5,7 @@ module Graphics.QML.Internal.BindCore where +{#import Graphics.QML.Internal.BindPrim #} {#import Graphics.QML.Internal.BindObj #} import Foreign.C.Types@@ -70,10 +71,7 @@ {#fun hsqml_create_engine as ^ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle',- castPtr `Ptr ()',- fromBool `Bool',- fromBool `Bool',- castPtr `Ptr ()',+ id `HsQMLStringHandle', withTrivialCb* `TrivialCb'} -> `()' #}
src/Graphics/QML/Internal/BindObj.chs view
@@ -4,8 +4,10 @@ module Graphics.QML.Internal.BindObj where +import Graphics.QML.Internal.Types+{#import Graphics.QML.Internal.BindPrim #}+ import Control.Exception (bracket_)-import Data.Typeable import Foreign.C.Types import Foreign.Ptr import Foreign.ForeignPtr.Safe@@ -28,8 +30,6 @@ {} -> `CInt' id #} -type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()- foreign import ccall "wrapper" marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc) @@ -48,8 +48,9 @@ {#fun unsafe hsqml_create_class as ^ {id `Ptr CUInt',+ id `Ptr CUInt', id `Ptr CChar',- marshalStable* `TypeRep',+ marshalStable* `ClassInfo', id `Ptr (FunPtr UniformFunc)', id `Ptr (FunPtr UniformFunc)'} -> `Maybe HsQMLClassHandle' newClassHandle* #}@@ -89,20 +90,28 @@ (hsqmlObjectSetActive Nothing) action -{#fun unsafe hsqml_object_get_haskell as ^+{#fun unsafe hsqml_object_get_hs_typerep as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `a' fromStable* #}+ `ClassInfo' fromStable* #} -{#fun unsafe hsqml_object_get_hs_typerep as ^+{#fun unsafe hsqml_object_get_hs_value as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `TypeRep' fromStable* #}+ `a' fromStable* #} {#fun unsafe hsqml_object_get_pointer as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} -> `Ptr ()' id #} -{#fun unsafe hsqml_get_object_handle as ^+{#fun unsafe hsqml_object_get_jval as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+ `HsQMLJValHandle' id #}++{#fun unsafe hsqml_get_object_from_pointer as ^ {id `Ptr ()'} ->+ `HsQMLObjectHandle' newObjectHandle* #}++{#fun unsafe hsqml_get_object_from_jval as ^+ {id `HsQMLJValHandle'} -> `HsQMLObjectHandle' newObjectHandle* #} {#fun hsqml_fire_signal as ^
src/Graphics/QML/Internal/BindPrim.chs view
@@ -5,6 +5,8 @@ module Graphics.QML.Internal.BindPrim where import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils import Foreign.Ptr import System.IO.Unsafe @@ -34,44 +36,150 @@ {id `HsQMLStringHandle'} -> `()' #} -{#fun unsafe hsqml_marshal_string as ^+{#fun unsafe hsqml_write_string as ^ {`Int', id `HsQMLStringHandle'} -> `Ptr CUShort' id #} -{#fun unsafe hsqml_unmarshal_string as ^+{#fun unsafe hsqml_read_string as ^ {id `HsQMLStringHandle', id `Ptr (Ptr CUShort)'} -> `Int' #} +withStrHndl :: (HsQMLStringHandle -> IO b) -> IO b+withStrHndl contFn =+ allocaBytes hsqmlStringSize $ \ptr -> do+ let str = HsQMLStringHandle ptr+ hsqmlInitString str+ ret <- contFn str+ hsqmlDeinitString str+ return ret+ ----- URL+-- JSValue -- -{#pointer *HsQMLUrlHandle as ^ newtype #}+{#pointer *HsQMLJValHandle as ^ newtype #} -{#fun unsafe hsqml_get_url_size as ^+{#fun unsafe hsqml_get_jval_size as ^ {} -> `Int' fromIntegral #} -hsqmlUrlSize :: Int-hsqmlUrlSize = unsafePerformIO $ hsqmlGetUrlSize+hsqmlJValSize :: Int+hsqmlJValSize = unsafePerformIO $ hsqmlGetJvalSize -{#fun unsafe hsqml_init_url as ^- {id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_get_jval_typeid as ^+ {} ->+ `Int' fromIntegral #}++hsqmlJValTypeId :: Int+hsqmlJValTypeId = unsafePerformIO $ hsqmlGetJvalTypeid++{#fun unsafe hsqml_init_jval_null as ^+ {id `HsQMLJValHandle',+ fromBool `Bool'} -> `()' #} -{#fun unsafe hsqml_deinit_url as ^- {id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_deinit_jval as ^+ {id `HsQMLJValHandle'} -> `()' #} -{#fun unsafe hsqml_marshal_url as ^- {id `Ptr CChar',- `Int',- id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_set_jval as ^+ {id `HsQMLJValHandle',+ id `HsQMLJValHandle'} -> `()' #} -{#fun unsafe hsqml_unmarshal_url as ^- {id `HsQMLUrlHandle',- id `Ptr (Ptr CChar)'} ->- `Int' #}+{#fun unsafe hsqml_init_jval_bool as ^+ {id `HsQMLJValHandle',+ fromBool `Bool'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_bool as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_bool as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_init_jval_int as ^+ {id `HsQMLJValHandle',+ id `CInt'} ->+ `()' #}++{#fun unsafe hsqml_init_jval_double as ^+ {id `HsQMLJValHandle',+ id `CDouble'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_number as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_int as ^+ {id `HsQMLJValHandle'} ->+ `CInt' id #}++{#fun unsafe hsqml_get_jval_double as ^+ {id `HsQMLJValHandle'} ->+ `CDouble' id #}++{#fun unsafe hsqml_init_jval_string as ^+ {id `HsQMLJValHandle',+ id `HsQMLStringHandle'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_string as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_string as ^+ {id `HsQMLJValHandle',+ id `HsQMLStringHandle'} ->+ `()' #}++fromJVal ::+ (HsQMLJValHandle -> IO Bool) -> (HsQMLJValHandle -> IO a) ->+ HsQMLJValHandle -> IO (Maybe a)+fromJVal isFn getFn jval = do+ is <- isFn jval+ if is then fmap Just $ getFn jval else return Nothing++withJVal ::+ (HsQMLJValHandle -> a -> IO ()) -> a -> (HsQMLJValHandle -> IO b) -> IO b+withJVal initFn val contFn =+ allocaBytes hsqmlJValSize $ \ptr -> do+ let jval = HsQMLJValHandle ptr+ initFn jval val+ ret <- contFn jval+ hsqmlDeinitJval jval+ return ret++--+-- Array+--++{#fun unsafe hsqml_init_jval_array as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_array as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_array_length as ^+ {id `HsQMLJValHandle'} ->+ `Int' fromIntegral #}++{#fun unsafe hsqml_jval_array_get as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int',+ id `HsQMLJValHandle'} ->+ `()' #}++{#fun unsafe hsqml_jval_array_set as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int',+ id `HsQMLJValHandle'} ->+ `()' #}
src/Graphics/QML/Internal/Marshal.hs view
@@ -1,24 +1,21 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies,- FlexibleContexts,- FlexibleInstances, Rank2Types #-} module Graphics.QML.Internal.Marshal where +import Graphics.QML.Internal.Types+import Graphics.QML.Internal.BindPrim+import Graphics.QML.Internal.BindObj+ import Control.Monad.Trans.Maybe import Data.Maybe import Data.Tagged import Foreign.Ptr import System.IO --- | Represents a QML type name.-newtype TypeName = TypeName {- typeName :: String-}- type ErrIO a = MaybeT IO a runErrIO :: ErrIO a -> IO ()@@ -31,97 +28,208 @@ errIO :: IO a -> ErrIO a errIO = MaybeT . fmap Just -type MTypeNameFunc t = Tagged t TypeName-type MValToHsFunc t = Ptr () -> ErrIO t-type MHsToValFunc t = t -> Ptr () -> IO ()-type MHsToAllocFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b)+tyInt, tyDouble, tyString, tyObject, tyVoid, tyJSValue :: TypeId+tyInt = TypeId 2+tyDouble = TypeId 6+tyString = TypeId 10+tyObject = TypeId 39+tyVoid = TypeId 43+tyJSValue = TypeId $ hsqmlJValTypeId +type MTypeCValFunc t = Tagged t TypeId+type MFromCValFunc t = Ptr () -> ErrIO t+type MToCValFunc t = t -> Ptr () -> IO ()+type MWithCValFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b)++type MFromJValFunc t = HsQMLJValHandle -> ErrIO t+type MWithJValFunc t = (forall b. t -> (HsQMLJValHandle -> IO b) -> IO b)++type MFromHndlFunc t = HsQMLObjectHandle -> IO t+type MToHndlFunc t = t -> IO HsQMLObjectHandle++type MarshallerFor t = Marshaller t+ (MarshalMode t ICanGetFrom ()) (MarshalMode t ICanPassTo ())+ (MarshalMode t ICanReturnTo ())+ (MarshalMode t IIsObjType ()) (MarshalMode t IGetObjType ())++type MarshallerForMode t m = Marshaller t+ (m ICanGetFrom) (m ICanPassTo) (m ICanReturnTo)+ (m IIsObjType) (m IGetObjType)+ -- | The class 'Marshal' allows Haskell values to be marshalled to and from the -- QML environment. class Marshal t where- -- | The 'MarshalMode' associated type parameter specifies the type of- -- marshalling functionality offered by the instance.- type MarshalMode t- -- | Yields the 'Marshaller' for the type @t@.- marshaller :: Marshaller t (MarshalMode t)+ -- | The 'MarshalMode' associated type family specifies the marshalling+ -- capabilities offered by the instance. @c@ indicates the capability being+ -- queried. @d@ is dummy parameter which allows certain instances to type+ -- check.+ type MarshalMode t c d+ -- | Yields the 'Marshaller' for the type @t@.+ marshaller :: MarshallerFor t --- | Base class containing core functionality for all 'MarshalMode's.-class MarshalBase m where- mTypeName_ :: forall t. Marshaller t m -> MTypeNameFunc t+-- | 'MarshalMode' for non-object types with bidirectional marshalling.+type family ModeBidi c+type instance ModeBidi ICanGetFrom = Yes+type instance ModeBidi ICanPassTo = Yes+type instance ModeBidi ICanReturnTo = Yes+type instance ModeBidi IIsObjType = No+type instance ModeBidi IGetObjType = No -mTypeName ::- forall t. (Marshal t, MarshalBase (MarshalMode t)) => MTypeNameFunc t-mTypeName = mTypeName_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for non-object types with from-only marshalling.+type family ModeFrom c+type instance ModeFrom ICanGetFrom = Yes+type instance ModeFrom ICanPassTo = No+type instance ModeFrom ICanReturnTo = No+type instance ModeFrom IIsObjType = No+type instance ModeFrom IGetObjType = No --- | Class for 'MarshalMode's which support marshalling QML-to-Haskell.-class (MarshalBase m) => MarshalToHs m where- mValToHs_ :: forall t. Marshaller t m -> MValToHsFunc t+-- | 'MarshalMode' for void in method returns.+type family ModeRetVoid c+type instance ModeRetVoid ICanGetFrom = No+type instance ModeRetVoid ICanPassTo = No+type instance ModeRetVoid ICanReturnTo = Yes+type instance ModeRetVoid IIsObjType = No+type instance ModeRetVoid IGetObjType = No -mValToHs ::- forall t. (Marshal t, MarshalToHs (MarshalMode t)) => MValToHsFunc t-mValToHs = mValToHs_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for object types with bidirectional marshalling.+type family ModeObjBidi a c+type instance ModeObjBidi a ICanGetFrom = Yes+type instance ModeObjBidi a ICanPassTo = Yes+type instance ModeObjBidi a ICanReturnTo = Yes+type instance ModeObjBidi a IIsObjType = Yes+type instance ModeObjBidi a IGetObjType = a --- | Class for 'MarshalMode's which support marshalling Haskell-to-QML.-class (MarshalBase m) => MarshalToValRaw m where- mHsToVal_ :: forall t. Marshaller t m -> MHsToValFunc t- mHsToAlloc_ :: forall t. Marshaller t m -> MHsToAllocFunc t+-- | 'MarshalMode' for object types with from-only marshalling.+type family ModeObjFrom a c+type instance ModeObjFrom a ICanGetFrom = Yes+type instance ModeObjFrom a ICanPassTo = No+type instance ModeObjFrom a ICanReturnTo = No+type instance ModeObjFrom a IIsObjType = Yes+type instance ModeObjFrom a IGetObjType = a -mHsToVal ::- forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToValFunc t-mHsToVal = mHsToVal_ (marshaller :: Marshaller t (MarshalMode t))+-- | Type value indicating a capability is supported.+data Yes -mHsToAlloc ::- forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToAllocFunc t-mHsToAlloc = mHsToAlloc_ (marshaller :: Marshaller t (MarshalMode t))+-- | Type value indicating a capability is not supported.+data No --- | Class for 'MarshalMode's which support marshalling Haskell-to-QML,--- excluding the return of void from methods.-class (MarshalToValRaw m) => MarshalToVal m where+-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- received from QML.+type CanGetFrom t = MarshalMode t ICanGetFrom () +-- | Type index into 'MarshalMode' for querying if the mode supports receiving+-- values from QML.+data ICanGetFrom++-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- passed to QML.+type CanPassTo t = MarshalMode t ICanPassTo ()++-- | Type index into 'MarshalMode' for querying if the mode supports passing+-- values to QML.+data ICanPassTo++-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- returned to QML.+type CanReturnTo t = MarshalMode t ICanReturnTo ()++-- | Type index into 'MarshalMode' for querying if the mode supports returning+-- values to QML.+data ICanReturnTo++-- | Type function equal to 'Yes' if the marshallable type @t@ is an object.+type IsObjType t = MarshalMode t IIsObjType ()++-- | Type index into 'MarshalMode' for querying if the mode supports an object+-- type.+data IIsObjType++-- | Type function which returns the type encapsulated by the object handles+-- used by the marshallable type @t@.+type GetObjType t = MarshalMode t IGetObjType ()++-- | Type index into 'MarshalMode' for querying the type encapsulated by the+-- mode's object handles.+data IGetObjType+ -- | Encapsulates the functionality to needed to implement an instance of -- 'Marshal' so that such instances can be defined without access to -- implementation details.-data family Marshaller t m+data Marshaller t u v w x y = Marshaller {+ mTypeCVal_ :: !(MTypeCValFunc t),+ mFromCVal_ :: !(MFromCValFunc t),+ mToCVal_ :: !(MToCValFunc t),+ mWithCVal_ :: !(MWithCValFunc t),+ mFromJVal_ :: !(MFromJValFunc t),+ mWithJVal_ :: !(MWithJValFunc t),+ mFromHndl_ :: !(MFromHndlFunc t),+ mToHndl_ :: !(MToHndlFunc t)+} --- | 'MarshalMode' for built-in data types.-data ValBidi+mTypeCVal :: forall t. (Marshal t) => MTypeCValFunc t+mTypeCVal = mTypeCVal_ (marshaller :: MarshallerFor t) -data instance Marshaller t ValBidi = MValBidi {- mValBidi_typeName :: !(MTypeNameFunc t),- mValBidi_valToHs :: !(MValToHsFunc t),- mValBidi_hsToVal :: !(MHsToValFunc t),- mValBidi_hsToAlloc :: !(MHsToAllocFunc t)}+mFromCVal :: forall t. (Marshal t) => MFromCValFunc t+mFromCVal = mFromCVal_ (marshaller :: MarshallerFor t) -instance MarshalBase ValBidi where- mTypeName_ = mValBidi_typeName+mToCVal :: forall t. (Marshal t) => MToCValFunc t+mToCVal = mToCVal_ (marshaller :: MarshallerFor t) -instance MarshalToHs ValBidi where- mValToHs_ = mValBidi_valToHs+mWithCVal :: forall t. (Marshal t) => MWithCValFunc t+mWithCVal = mWithCVal_ (marshaller :: MarshallerFor t) -instance MarshalToValRaw ValBidi where- mHsToVal_ = mValBidi_hsToVal- mHsToAlloc_ = mValBidi_hsToAlloc+mFromJVal :: forall t. (Marshal t) => MFromJValFunc t+mFromJVal = mFromJVal_ (marshaller :: MarshallerFor t) -instance MarshalToVal ValBidi where+mWithJVal :: forall t. (Marshal t) => MWithJValFunc t+mWithJVal = mWithJVal_ (marshaller :: MarshallerFor t) --- | 'MarshalMode' for void in method returns.-data ValFnRetVoid+mFromHndl :: forall t. (Marshal t) => MFromHndlFunc t+mFromHndl = mFromHndl_ (marshaller :: MarshallerFor t) -data instance Marshaller t ValFnRetVoid = MValFnRetVoid {- mValFnRetVoid_typeName :: !(MTypeNameFunc t),- mValFnRetVoid_hsToVal :: !(MHsToValFunc t),- mValFnRetVoid_hsToAlloc :: !(MHsToAllocFunc t)}+mToHndl :: forall t. (Marshal t) => MToHndlFunc t+mToHndl = mToHndl_ (marshaller :: MarshallerFor t) -instance MarshalBase ValFnRetVoid where- mTypeName_ = mValFnRetVoid_typeName+unimplFromCVal :: MFromCValFunc t+unimplFromCVal = \_ -> error "Type does not support mFromCVal." -instance MarshalToValRaw ValFnRetVoid where- mHsToVal_ = mValFnRetVoid_hsToVal- mHsToAlloc_ = mValFnRetVoid_hsToAlloc+unimplToCVal :: MToCValFunc t+unimplToCVal = \_ _ -> error "Type does not support mToCVal." +unimplWithCVal :: MWithCValFunc t+unimplWithCVal = \_ _ -> error "Type does not support mWithCVal."++unimplFromJVal :: MFromJValFunc t+unimplFromJVal = \_ -> error "Type does not support mFromJVal."++unimplWithJVal :: MWithJValFunc t+unimplWithJVal = \_ _ -> error "Type does not support mWithJVal."++unimplFromHndl :: MFromHndlFunc t+unimplFromHndl = \_ -> error "Type does not support mFromHndl."++unimplToHndl :: MToHndlFunc t+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 ->+ hsqmlSetJval (HsQMLJValHandle $ castPtr ptr) jval++jvalWithCVal :: (Marshal t) => MWithCValFunc t+jvalWithCVal = \val f -> mWithJVal val $ \(HsQMLJValHandle ptr) ->+ f $ castPtr ptr+ instance Marshal () where- type MarshalMode () = ValFnRetVoid- marshaller = MValFnRetVoid {- mValFnRetVoid_typeName = Tagged $ TypeName "",- mValFnRetVoid_hsToVal = \_ _ -> return (),- mValFnRetVoid_hsToAlloc = \_ f -> f nullPtr}+ type MarshalMode () c d = ModeRetVoid c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyVoid,+ mFromCVal_ = unimplFromCVal,+ mToCVal_ = \_ _ -> return (),+ mWithCVal_ = unimplWithCVal,+ mFromJVal_ = unimplFromJVal,+ mWithJVal_ = unimplWithJVal,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}
src/Graphics/QML/Internal/MetaObj.hs view
@@ -2,7 +2,7 @@ import Graphics.QML.Internal.BindObj import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Types import Control.Monad import Control.Monad.Trans.State@@ -28,6 +28,9 @@ crlEmpty :: CRList a crlEmpty = CRList 0 [] +crlSingle :: a -> CRList a+crlSingle x = CRList 1 [x]+ crlAppend1 :: CRList a -> a -> CRList a crlAppend1 (CRList n xs) x = CRList (n+1) (x:xs) @@ -49,16 +52,39 @@ pokeElemOff p n' x' pokeRev p xs n' +crlToList :: CRList a -> [a]+crlToList (CRList _ lst) = reverse lst+ -- -- Meta Object Compiler -- +data MemberKind+ = MethodMember+ | PropertyMember+ | SignalMember+ deriving (Bounded, Enum, Eq)++-- | Represents a named member of the QML class which wraps type @tt@.+data Member tt = Member {+ memberKind :: MemberKind,+ memberName :: String,+ memberType :: TypeId,+ memberParams :: [TypeId],+ memberFun :: UniformFunc,+ memberFunAux :: Maybe UniformFunc,+ memberKey :: Maybe MemberKey+}+ data MOCState = MOCState { mData :: CRList CUInt, mDataMethodsIdx :: Maybe Int, mDataPropsIdx :: Maybe Int,- mStrData :: CRList CChar,- mStrDataMap :: Map String CUInt,+ mStrChar :: CRList CChar,+ mStrInfo :: CRList CUInt,+ mStrMap :: Map String CUInt,+ mParamMap :: Map [TypeId] CUInt,+ mSigMap :: Map MemberKey CUInt, mFuncMethods :: CRList (Maybe UniformFunc), mFuncProperties :: CRList (Maybe UniformFunc), mMethodCount :: Int,@@ -69,8 +95,8 @@ -- | Generate MOC meta-data from a class name and member list. compileClass :: String -> [Member tt] -> MOCState compileClass name ms = - let enc = flip execState newMOCState $ do- writeInt 5 -- Revision+ let enc = flip execState (newMOCState enc) $ do+ writeInt 7 -- Revision writeString name -- Class name writeInt 0 >> writeInt 0 -- Class info writeIntegral $@@ -85,9 +111,12 @@ writeInt 0 >> writeInt 0 -- Constructors writeInt 0 -- Flags writeIntegral $ mSignalCount enc -- Signals+ mapM_ writeMethodParams $ filterMembers SignalMember ms+ mapM_ writeMethodParams $ filterMembers MethodMember ms mapM_ writeMethod $ filterMembers SignalMember ms mapM_ writeMethod $ filterMembers MethodMember ms mapM_ writeProperty $ filterMembers PropertyMember ms+ mapM_ writePropertySig $ filterMembers PropertyMember ms writeInt 0 in enc @@ -95,10 +124,12 @@ filterMembers k ms = filter (\m -> k == memberKind m) ms -newMOCState :: MOCState-newMOCState =- MOCState crlEmpty Nothing Nothing crlEmpty Map.empty crlEmpty crlEmpty 0 0 0-+newMOCState :: MOCState -> MOCState+newMOCState enc = MOCState+ crlEmpty Nothing Nothing crlEmpty (crlSingle strCount) Map.empty+ Map.empty Map.empty crlEmpty crlEmpty 0 0 0+ where strCount = fromIntegral $ Map.size $ mStrMap enc+ writeInt :: CUInt -> State MOCState () writeInt int = do state <- get@@ -112,35 +143,58 @@ writeString :: String -> State MOCState () writeString str = do state <- get- let msd = mStrData state- msdMap = mStrDataMap state- case (Map.lookup str msdMap) of+ let msChr = mStrChar state+ msInf = mStrInfo state+ msMap = mStrMap state+ case (Map.lookup str msMap) of Just idx -> writeInt idx Nothing -> do- let idx = crlLen msd- msd' = msd `crlAppend` (map castCharToCChar str) `crlAppend1` 0- msdMap' = Map.insert str (fromIntegral idx) msdMap+ let idx = crlLen msInf - 1+ msChr' = msChr `crlAppend` (map castCharToCChar str) `crlAppend1` 0+ msInf' = msInf `crlAppend1` (fromIntegral $ crlLen msChr')+ msMap' = Map.insert str (fromIntegral idx) msMap put $ state {- mStrData = msd',- mStrDataMap = msdMap'}+ mStrChar = msChr',+ mStrInfo = msInf',+ mStrMap = msMap'} writeIntegral idx +writeMethodParams :: Member tt -> State MOCState ()+writeMethodParams m = do+ state <- get+ let types = memberTypes m+ datal = mData state+ mpMap = mParamMap state+ case (Map.lookup types mpMap) of+ Just idx -> 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) ""+ writeMethod :: Member tt -> State MOCState () writeMethod m = do idx <- get >>= return . crlLen . mData- writeString $ methodSignature m- writeString $ methodParameters m- writeString $ typeName $ memberType m+ paramMap <- get >>= return . mParamMap+ writeString $ memberName m+ writeIntegral $ length $ memberParams m+ writeInt $ fromMaybe 0 $ flip Map.lookup paramMap $ memberTypes m writeString "" let (mc,sc,flags) = case memberKind m of SignalMember -> (0,1,mfMethodSignal)- _ -> (1,0,0)+ _ -> (1,0,mfMethodMethod) writeInt (mfAccessPublic .|. mfMethodScriptable .|. flags) state <- get put $ state { mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx), mMethodCount = mc + (mMethodCount state), mSignalCount = sc + (mSignalCount state),+ mSigMap = maybe (mSigMap state) (\k ->+ Map.insert k (fromIntegral $ mSignalCount state) (mSigMap state)) $+ memberKey m, mFuncMethods = mFuncMethods state `crlAppend1` (Just $ memberFun m)} return () @@ -148,9 +202,10 @@ writeProperty p = do idx <- get >>= return . crlLen . mData writeString $ memberName p- writeString $ typeName $ memberType p+ writeInt $ typeId $ memberType p writeInt (pfReadable .|. pfScriptable .|.- if (isJust $ memberFunAux p) then pfWritable 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),@@ -160,20 +215,17 @@ } return () -foldr0 :: (a -> a -> a) -> a -> [a] -> a-foldr0 _ x [] = x-foldr0 f _ xs = foldr1 f xs+writePropertySig :: Member tt -> State MOCState ()+writePropertySig p = do+ state <- get+ writeInt $ fromMaybe 0 $ maybe Nothing (flip Map.lookup $ mSigMap state) $+ memberKey p -methodSignature :: Member tt -> String-methodSignature method =- let paramTypes = memberParams method- in (showString (memberName method) . showChar '(' .- foldr0 (\l r -> l . showChar ',' . r) id- (map (showString . typeName) paramTypes) . showChar ')') ""+memberTypes :: Member tt -> [TypeId]+memberTypes m = memberType m : memberParams m -methodParameters :: Member tt -> String-methodParameters method =- replicate (flip (-) 1 $ length $ memberParams method) ','+typeId :: TypeId -> CUInt+typeId (TypeId tyid) = fromIntegral tyid -- -- Constants
− src/Graphics/QML/Internal/Objects.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE- ScopedTypeVariables,- TypeFamilies,- FlexibleContexts,- FlexibleInstances,- Rank2Types- #-}--module Graphics.QML.Internal.Objects where--import Graphics.QML.Internal.BindObj-import Graphics.QML.Internal.Marshal--import Data.Typeable-import Data.Bits-import Data.Char--data MemberKind- = MethodMember- | PropertyMember- | SignalMember- deriving (Bounded, Enum, Eq)---- | Represents a named member of the QML class which wraps type @tt@.-data Member tt = Member {- memberKind :: MemberKind,- memberName :: String,- memberType :: TypeName,- memberParams :: [TypeName],- memberFun :: UniformFunc,- memberFunAux :: Maybe UniformFunc,- memberKey :: Maybe TypeRep-}---- | Represents the API of the QML class which wraps the type @tt@.-newtype ClassDef tt = ClassDef {- classMembers :: [Member tt]-}---- | The class 'Object' allows Haskell types to expose an object-oriented--- interface to QML. -class (Typeable tt) => Object tt where- classDef :: ClassDef tt--type MObjToHsFunc t = HsQMLObjectHandle -> IO t-type MHsToObjFunc t = t -> IO HsQMLObjectHandle---- | Type function yielding the object type specified by a given 'MarshalMode'.-type family ModeObj m---- | Type function yielding the object type speficied by a given marshallable--- type @tt@.-type ThisObj tt = ModeObj (MarshalMode tt)---- | Class for 'MarshalMode's which support marshalling QML-to-Haskell--- in contexts specific to objects.-class (MarshalBase m) => MarshalFromObj m where- mObjToHs_ :: forall t. Marshaller t m -> MObjToHsFunc t--mObjToHs ::- forall t. (Marshal t, MarshalFromObj (MarshalMode t)) => MObjToHsFunc t-mObjToHs = mObjToHs_ (marshaller :: Marshaller t (MarshalMode t))---- | Class for 'MarshalMode's which support marshalling Haskell-to-QML--- in contexts specific to objects.-class (MarshalBase m) => MarshalToObj m where- mHsToObj_ :: forall t. Marshaller t m -> MHsToObjFunc t--mHsToObj ::- forall t. (Marshal t, MarshalToObj (MarshalMode t)) => MHsToObjFunc t-mHsToObj = mHsToObj_ (marshaller :: Marshaller t (MarshalMode t))---- | 'MarshalMode' for object types.-data ValObjBidi a-type instance ModeObj (ValObjBidi a) = a--data instance Marshaller t (ValObjBidi a) = MValObjBidi {- mValObjBidi_typeName :: !(MTypeNameFunc t),- mValObjBidi_valToHs :: !(MValToHsFunc t),- mValObjBidi_hsToVal :: !(MHsToValFunc t),- mValObjBidi_hsToAlloc :: !(MHsToAllocFunc t),- mValObjBidi_objToHs :: !(MObjToHsFunc t),- mValObjBidi_hsToObj :: !(MHsToObjFunc t)}--instance MarshalBase (ValObjBidi a) where- mTypeName_ = mValObjBidi_typeName--instance MarshalToHs (ValObjBidi a) where- mValToHs_ = mValObjBidi_valToHs--instance MarshalToValRaw (ValObjBidi a) where- mHsToVal_ = mValObjBidi_hsToVal- mHsToAlloc_ = mValObjBidi_hsToAlloc--instance MarshalToVal (ValObjBidi a) where--instance MarshalToObj (ValObjBidi a) where- mHsToObj_ = mValObjBidi_hsToObj--instance MarshalFromObj (ValObjBidi a) where- mObjToHs_ = mValObjBidi_objToHs---- | 'MarshalMode' for object types, operating only in the QML-to-Haskell--- direction.-data ValObjToOnly a--type instance ModeObj (ValObjToOnly a) = a--data instance Marshaller t (ValObjToOnly a) = MValObjToOnly {- mValObjToOnly_typeName :: !(MTypeNameFunc t),- mValObjToOnly_valToHs :: !(MValToHsFunc t),- mValObjToOnly_objToHs :: !(MObjToHsFunc t)}--instance MarshalBase (ValObjToOnly a) where- mTypeName_ = mValObjToOnly_typeName--instance MarshalToHs (ValObjToOnly a) where- mValToHs_ = mValObjToOnly_valToHs--instance MarshalFromObj (ValObjToOnly a) where- mObjToHs_ = mValObjToOnly_objToHs-
+ src/Graphics/QML/Internal/Types.hs view
@@ -0,0 +1,21 @@+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++newtype TypeId = TypeId Int deriving (Eq, Ord)++type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()++data MemberKey+ = TypeKey TypeRep+ | DataKey Unique+ deriving (Eq, Ord)++data ClassInfo = ClassInfo {+ cinfoObjType :: TypeRep,+ cinfoSignals :: Map MemberKey Int+}
src/Graphics/QML/Marshal.hs view
@@ -1,32 +1,46 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies,- TypeSynonymInstances, FlexibleInstances #-} -- | Type classs and instances for marshalling values between Haskell and QML. module Graphics.QML.Marshal (+ -- * Marshalling Type-class Marshal ( type MarshalMode, marshaller),- MarshalToHs,- MarshalToValRaw,- MarshalToVal,- MarshalFromObj,- MarshalToObj,- ValBidi,- ValFnRetVoid,- ValObjBidi,- ValObjToOnly,- ThisObj,- Marshaller + ModeBidi,+ ModeFrom,+ ModeRetVoid,+ ModeObjBidi,+ ModeObjFrom,+ Yes,+ CanGetFrom,+ ICanGetFrom,+ CanPassTo,+ ICanPassTo,+ CanReturnTo,+ ICanReturnTo,+ IsObjType,+ IIsObjType,+ GetObjType,+ IGetObjType,+ Marshaller,++ -- * Custom Marshallers+ bidiMarshallerIO,+ bidiMarshaller,+ fromMarshallerIO,+ fromMarshaller, ) where import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Types +import Control.Monad+import Control.Monad.Trans.Maybe import Data.Maybe import Data.Tagged import Data.Int@@ -38,123 +52,230 @@ import Foreign.Marshal.Alloc import Foreign.Ptr import Foreign.Storable-import Network.URI (- URI (URI), URIAuth (URIAuth),- parseURIReference, unEscapeString,- uriToString, escapeURIString, nullURI,- isUnescapedInURI) --+-- Boolean built-in type+--++instance Marshal Bool where+ type MarshalMode Bool c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \ptr ->+ MaybeT $ fromJVal hsqmlIsJvalBool hsqmlGetJvalBool ptr,+ mWithJVal_ = \bool f ->+ withJVal hsqmlInitJvalBool bool f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}++-- -- Int32/int built-in type -- instance Marshal Int32 where- type MarshalMode Int32 = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "int",- mValBidi_valToHs = \ptr ->- errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,- mValBidi_hsToVal = \int ptr ->- poke (castPtr ptr :: Ptr CInt) (fromIntegral int),- mValBidi_hsToAlloc = \int f ->- alloca $ \(ptr :: Ptr CInt) ->- mHsToVal int (castPtr ptr) >> f (castPtr ptr)}+ type MarshalMode Int32 c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyInt,+ mFromCVal_ = \ptr ->+ errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,+ mToCVal_ = \int ptr ->+ poke (castPtr ptr :: Ptr CInt) (fromIntegral int),+ mWithCVal_ = \int f ->+ alloca $ \(ptr :: Ptr CInt) ->+ mToCVal int (castPtr ptr) >> f (castPtr ptr),+ mFromJVal_ = \ptr ->+ MaybeT $ fromJVal hsqmlIsJvalNumber (+ fmap fromIntegral . hsqmlGetJvalInt) ptr,+ mWithJVal_ = \int f ->+ withJVal hsqmlInitJvalInt (fromIntegral int) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} instance Marshal Int where- type MarshalMode Int = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "int",- mValBidi_valToHs = fmap (fromIntegral :: Int32 -> Int) . mValToHs,- mValBidi_hsToVal = \int ptr -> mHsToVal (fromIntegral int :: Int32) ptr,- mValBidi_hsToAlloc = \int f -> mHsToAlloc (fromIntegral int :: Int32) f}+ type MarshalMode Int c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyInt,+ 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,+ mWithJVal_ = \int f -> mWithJVal (fromIntegral int :: Int32) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -- -- Double/double built-in type -- instance Marshal Double where- type MarshalMode Double = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "double",- mValBidi_valToHs = \ptr ->- errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,- mValBidi_hsToVal = \num ptr ->- poke (castPtr ptr :: Ptr CDouble) (realToFrac num),- mValBidi_hsToAlloc = \num f ->- alloca $ \(ptr :: Ptr CDouble) ->- mHsToVal num (castPtr ptr) >> f (castPtr ptr)}+ type MarshalMode Double c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyDouble,+ mFromCVal_ = \ptr ->+ errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,+ mToCVal_ = \num ptr ->+ poke (castPtr ptr :: Ptr CDouble) (realToFrac num),+ mWithCVal_ = \num f ->+ alloca $ \(ptr :: Ptr CDouble) ->+ mToCVal num (castPtr ptr) >> f (castPtr ptr),+ mFromJVal_ = \ptr ->+ MaybeT $ fromJVal hsqmlIsJvalNumber (+ fmap realToFrac . hsqmlGetJvalDouble) ptr,+ mWithJVal_ = \num f ->+ withJVal hsqmlInitJvalDouble (realToFrac num) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -- -- Text/QString built-in type -- instance Marshal Text where- type MarshalMode Text = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QString",- mValBidi_valToHs = \ptr -> errIO $ do- pair <- alloca (\bufPtr -> do- len <- hsqmlUnmarshalString (HsQMLStringHandle $ castPtr ptr) bufPtr- buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- uncurry T.fromPtr pair,- mValBidi_hsToVal = \txt ptr -> do- array <- hsqmlMarshalString- (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)- T.unsafeCopyToPtr txt (castPtr array),- mValBidi_hsToAlloc = \txt f ->- allocaBytes hsqmlStringSize $ \ptr -> do- hsqmlInitString $ HsQMLStringHandle ptr- mHsToVal txt (castPtr ptr)- ret <- f (castPtr ptr)- hsqmlDeinitString $ HsQMLStringHandle ptr- return ret}+ type MarshalMode Text c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyString,+ mFromCVal_ = \ptr -> errIO $ do+ pair <- alloca (\bufPtr -> do+ len <- hsqmlReadString (+ HsQMLStringHandle $ castPtr ptr) bufPtr+ buf <- peek bufPtr+ return (castPtr buf, fromIntegral len))+ uncurry T.fromPtr pair,+ mToCVal_ = \txt ptr -> do+ array <- hsqmlWriteString+ (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)+ T.unsafeCopyToPtr txt (castPtr array),+ mWithCVal_ = \txt f ->+ withStrHndl $ \(HsQMLStringHandle ptr) -> do+ mToCVal txt $ castPtr ptr+ f $ castPtr ptr,+ mFromJVal_ = \jval ->+ MaybeT $ withStrHndl $ \sHndl -> runMaybeT $ do+ MaybeT $ fromJVal hsqmlIsJvalString (+ flip hsqmlGetJvalString sHndl) jval+ let (HsQMLStringHandle ptr) = sHndl+ mFromCVal $ castPtr ptr,+ mWithJVal_ = \txt f ->+ mWithCVal txt $ \ptr -> withJVal hsqmlInitJvalString (+ HsQMLStringHandle $ castPtr ptr) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} ----- String/QString built-in type+-- Maybe -- -instance Marshal String where- type MarshalMode String = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QString",- mValBidi_valToHs = fmap T.unpack . mValToHs,- mValBidi_hsToVal = \txt ptr -> mHsToVal (T.pack txt) ptr,- mValBidi_hsToAlloc = \txt f -> mHsToAlloc (T.pack txt) f}+instance (Marshal a) => Marshal (Maybe a) where+ type MarshalMode (Maybe a) ICanGetFrom d = MarshalMode a ICanGetFrom d+ type MarshalMode (Maybe a) ICanPassTo d = MarshalMode a ICanPassTo d+ type MarshalMode (Maybe a) ICanReturnTo d = MarshalMode a ICanReturnTo d+ type MarshalMode (Maybe a) IIsObjType d = No+ type MarshalMode (Maybe a) IGetObjType d = No+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \jval -> errIO $ runMaybeT $ mFromJVal jval,+ mWithJVal_ = \val f ->+ case val of+ Just val' -> mWithJVal val' f+ Nothing -> withJVal hsqmlInitJvalNull False f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} ----- URI/QUrl built-in type+-- List -- -mapURIStrings :: (String -> String) -> URI -> URI-mapURIStrings f (URI scheme auth path query frag) =- URI (f scheme) (mapAuth auth) (f path) (f query) (f frag)- where mapAuth (Just (URIAuth user name port)) =- Just $ URIAuth (f user) (f name) (f port)- mapAuth Nothing = Nothing+instance (Marshal a) => Marshal [a] where+ type MarshalMode [a] ICanGetFrom d = MarshalMode a ICanGetFrom d+ type MarshalMode [a] ICanPassTo d = MarshalMode a ICanPassTo d+ type MarshalMode [a] ICanReturnTo d = MarshalMode a ICanReturnTo d+ type MarshalMode [a] IIsObjType d = No+ type MarshalMode [a] IGetObjType d = No+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \jval -> MaybeT $ do+ len <- hsqmlGetJvalArrayLength jval+ withJVal hsqmlInitJvalNull True $ \tmp ->+ runMaybeT $ forM [0..len-1] $ \i -> do+ errIO $ hsqmlJvalArrayGet jval i tmp+ mFromJVal tmp,+ mWithJVal_ = \vs f ->+ withJVal hsqmlInitJvalArray (length vs) $ \jval -> do+ forM_ (zip [0..] vs) $ uncurry $ \i val ->+ mWithJVal val $ \jval' ->+ hsqmlJvalArraySet jval i jval'+ f jval,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -instance Marshal URI where- type MarshalMode URI = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QUrl",- mValBidi_valToHs = \ptr -> errIO $ do- pair <- alloca (\bufPtr -> do- len <- hsqmlUnmarshalUrl (HsQMLUrlHandle $ castPtr ptr) bufPtr- buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- str <- peekCStringLen pair- free $ fst pair- return $ mapURIStrings unEscapeString $- fromMaybe nullURI $ parseURIReference str,- mValBidi_hsToVal = \uri ptr ->- let str = uriToString id (mapURIStrings- (escapeURIString isUnescapedInURI) uri) ""- in withCStringLen str (\(buf, bufLen) ->- hsqmlMarshalUrl buf bufLen (HsQMLUrlHandle $ castPtr ptr)),- mValBidi_hsToAlloc = \uri f ->- allocaBytes hsqmlUrlSize $ \ptr -> do- hsqmlInitUrl $ HsQMLUrlHandle ptr- mHsToVal uri (castPtr ptr)- ret <- f (castPtr ptr)- hsqmlDeinitUrl $ HsQMLUrlHandle ptr- return ret}+type BidiMarshaller a b = Marshaller b+ (MarshalMode a ICanGetFrom ())+ (MarshalMode a ICanPassTo ())+ (MarshalMode a ICanReturnTo ())+ (MarshalMode a IIsObjType ())+ (MarshalMode a IGetObjType ())++-- | Provides a bidirectional '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 'ModeObjBidi' or+-- 'ModeBidi' depending on whether @a@ was an object type or not.+bidiMarshallerIO ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>+ (a -> IO b) -> (b -> IO a) -> BidiMarshaller a b+bidiMarshallerIO fromFn toFn = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+ 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,+ mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,+ mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,+ mToHndl_ = \val -> mToHndl =<< toFn val}++-- | Variant of 'bidiMarshallerIO' where the conversion functions between types+-- @a@ and @b@ do not live in the IO monad.+bidiMarshaller ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>+ (a -> b) -> (b -> a) -> BidiMarshaller a b+bidiMarshaller fromFn toFn =+ bidiMarshallerIO (return . fromFn) (return . toFn)++type FromMarshaller a b = Marshaller b+ (MarshalMode a ICanGetFrom ())+ No+ No+ (MarshalMode a IIsObjType ())+ (MarshalMode a IGetObjType ())++-- | Provides a "from" '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 'ModeObjFrom' or 'ModeFrom'+-- depending on whether @a@ was an object type or not.+fromMarshallerIO ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes) =>+ (a -> IO b) -> FromMarshaller a b+fromMarshallerIO fromFn = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+ mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr,+ mToCVal_ = unimplToCVal,+ mWithCVal_ = unimplWithCVal,+ mFromJVal_ = \ptr -> (errIO . fromFn) =<< mFromJVal ptr,+ mWithJVal_ = unimplWithJVal,+ mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,+ mToHndl_ = unimplToHndl}++-- | Variant of 'fromMarshallerIO' where the conversion function between types+-- @a@ and @b@ does not live in the IO monad.+fromMarshaller ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes) =>+ (a -> b) -> FromMarshaller a b+fromMarshaller fromFn = fromMarshallerIO (return . fromFn)
src/Graphics/QML/Objects.hs view
@@ -2,65 +2,79 @@ ScopedTypeVariables, TypeFamilies, FlexibleContexts,- FlexibleInstances+ FlexibleInstances,+ LiberalTypeSynonyms #-} -- | Facilities for defining new object types which can be marshalled between -- Haskell and QML. module Graphics.QML.Objects (+ -- * Object References+ ObjRef,+ newObject,+ newObjectDC,+ fromObjRef,++ -- * Dynamic Object References+ AnyObjRef,+ anyObjRef,+ fromAnyObjRef,+ -- * Class Definition- Object (- classDef),- ClassDef,+ Class,+ newClass,+ DefaultClass (+ classMembers), Member,- defClass, -- * Methods defMethod,+ defMethod', MethodSuffix, - -- * Properties- defPropertyRO,- defPropertyRW,- -- * Signals defSignal, fireSignal,- SignalKey (+ SignalKey,+ newSignalKey,+ SignalKeyClass ( type SignalParams), SignalSuffix, - -- * Object References- ObjRef,- newObject,- fromObjRef,-- -- * Dynamic Object References- AnyObjRef,- anyObjRef,- fromAnyObjRef,-- -- * Customer Marshallers- objSimpleMarshaller,- objBidiMarshaller+ -- * Properties+ defPropertyRO,+ defPropertySigRO,+ defPropertyRW,+ defPropertySigRW,+ defPropertyRO',+ defPropertySigRO',+ defPropertyRW',+ 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 import Data.Tagged import Data.Typeable import Data.IORef+import Data.Unique import Foreign.Ptr+import Foreign.ForeignPtr import Foreign.Storable import Foreign.Marshal.Alloc import Foreign.Marshal.Array@@ -76,30 +90,39 @@ objHndl :: HsQMLObjectHandle } -instance (Object tt) => Marshal (ObjRef tt) where- type MarshalMode (ObjRef tt) = ValObjBidi tt- marshaller = MValObjBidi {- mValObjBidi_typeName = Tagged $ TypeName "QObject*",- mValObjBidi_valToHs = \ptr -> do- any <- mValToHs ptr- MaybeT $ return $ fromAnyObjRef any,- mValObjBidi_hsToVal = \obj ptr ->- mHsToVal (AnyObjRef $ objHndl obj) ptr,- mValObjBidi_hsToAlloc = \obj f ->- mHsToAlloc (AnyObjRef $ objHndl obj) f,- mValObjBidi_objToHs = \hndl ->- return $ ObjRef hndl,- mValObjBidi_hsToObj = \obj ->- return $ objHndl obj}+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 an instance of a QML class given a value of the underlying Haskell --- type @tt@.-newObject :: forall tt. (Object tt) => tt -> IO (ObjRef tt)-newObject obj = do- cRec <- getClassRec (classDef :: ClassDef tt)- oHndl <- hsqmlCreateObject obj $ crecHndl cRec- return $ ObjRef oHndl+-- | 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 =+ fmap ObjRef $ hsqmlCreateObject obj cHndl +-- | Creates a QML object given a Haskell value of type @tt@ which has a+-- 'DefaultClass' instance.+newObjectDC :: forall tt. (DefaultClass tt) => tt -> IO (ObjRef tt)+newObjectDC obj = do+ clazz <- getDefaultClass :: IO (Class tt)+ newObject clazz obj+ -- | Returns the associated value of the underlying Haskell type @tt@ from an -- instance of the QML class which wraps it. fromObjRef :: ObjRef tt -> tt@@ -108,7 +131,7 @@ fromObjRefIO :: ObjRef tt -> IO tt fromObjRefIO =- hsqmlObjectGetHaskell . objHndl + 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@@ -118,24 +141,25 @@ } instance Marshal AnyObjRef where- type MarshalMode AnyObjRef = ValObjBidi ()- marshaller = MValObjBidi {- mValObjBidi_typeName = Tagged $ TypeName "QObject*",- mValObjBidi_valToHs = \ptr -> MaybeT $ do- objPtr <- peek (castPtr ptr)- hndl <- hsqmlGetObjectHandle objPtr- return $ if isNullObjectHandle hndl- then Nothing else Just $ AnyObjRef hndl,- mValObjBidi_hsToVal = \obj ptr -> do- objPtr <- hsqmlObjectGetPointer $ anyObjHndl obj- poke (castPtr ptr) objPtr,- mValObjBidi_hsToAlloc = \obj f ->- alloca $ \(ptr :: Ptr (Ptr ())) ->- flip mHsToVal (castPtr ptr) obj >> f (castPtr ptr),- mValObjBidi_objToHs = \hndl ->- return $ AnyObjRef hndl,- mValObjBidi_hsToObj = \obj ->- return $ anyObjHndl obj}+ 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@@ -143,70 +167,75 @@ -- | Attempts to downcast an 'AnyObjRef' into an 'ObjRef' with the specific -- underlying Haskell type @tt@.-fromAnyObjRef :: (Object tt) => AnyObjRef -> Maybe (ObjRef tt)+fromAnyObjRef :: (Typeable tt) => AnyObjRef -> Maybe (ObjRef tt) fromAnyObjRef = unsafePerformIO . fromAnyObjRefIO -fromAnyObjRefIO :: forall tt. (Object tt) => AnyObjRef -> IO (Maybe (ObjRef tt))+fromAnyObjRefIO :: forall tt. (Typeable tt) =>+ AnyObjRef -> IO (Maybe (ObjRef tt)) fromAnyObjRefIO (AnyObjRef hndl) = do+ info <- hsqmlObjectGetHsTyperep hndl let srcRep = typeOf (undefined :: tt)- dstRep <- hsqmlObjectGetHsTyperep hndl+ dstRep = cinfoObjType info if srcRep == dstRep then return $ Just $ ObjRef hndl else return Nothing --- | Provides a QML-to-Haskell 'Marshaller' which allows you to define--- instances of 'Marshal' for custom 'Object' types. This allows a custom types--- to be passed into Haskell code as method parameters without having to--- manually deal with 'ObjRef's. ----- For example, an instance for 'MyObjectType' would be defined as follows:+-- Class ----- @--- instance Marshal MyObjectType where--- type MarshalMode MyObjectType = ValObjToOnly MyObjectType--- marshaller = objSimpleMarshaller--- @-objSimpleMarshaller ::- forall obj. (Object obj) => Marshaller obj (ValObjToOnly obj)-objSimpleMarshaller = MValObjToOnly {- mValObjToOnly_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),- mValObjToOnly_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,- mValObjToOnly_objToHs = hsqmlObjectGetHaskell} --- | Provides a bidirectional QML-to-Haskell and Haskell-to-QML 'Marshaller'--- which allows you to define instances of 'Marshal' for custom object types.--- This allows a custom type to be passed in and out of Haskell code via--- methods, properties, and signals, without having to manually deal with--- 'ObjRef's. Unlike the simple marshaller, this one must be given a function--- which specifies how to obtain an 'ObjRef' given a Haskell value.------ For example, an instance for 'MyObjectType' which simply creates a new--- object whenever one is required would be defined as follows:------ @--- instance Marshal MyObjectType where--- type MarshalMode MyObjectType = ValObjBidi MyObjectType--- marshaller = objBidiMarshaller newObject--- @-objBidiMarshaller ::- forall obj. (Object obj) =>- (obj -> IO (ObjRef obj)) -> Marshaller obj (ValObjBidi obj) -objBidiMarshaller newFn = MValObjBidi {- mValObjBidi_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),- mValObjBidi_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,- mValObjBidi_hsToVal = \obj ptr -> flip mHsToVal ptr =<< newFn obj,- mValObjBidi_hsToAlloc = \obj f -> flip mHsToAlloc f =<< newFn obj,- mValObjBidi_objToHs = hsqmlObjectGetHaskell,- mValObjBidi_hsToObj = fmap objHndl . newFn}+-- | Represents a QML class which wraps the type @tt@.+data Class tt = Class {+ classHndl :: HsQMLClassHandle+} +-- | Creates a new QML class for the type @tt@.+newClass :: forall tt. (Typeable tt) => [Member tt] -> IO (Class tt)+newClass = fmap Class . createClass (typeOf (undefined :: tt))++createClass :: forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle+createClass typRep ms = do+ hsqmlInit+ classId <- hsqmlGetNextClassId+ let constrs t = typeRepTyCon t : (concatMap constrs $ typeRepArgs t)+ name = foldr (\c s -> showString (tyConName c) .+ showChar '_' . s) id (constrs typRep) $ showInt classId ""+ ms' = ms ++ implicitSignals ms+ moc = compileClass name ms'+ sigs = filterMembers SignalMember ms'+ sigMap = Map.fromList $ flip zip [0..] $ map (fromJust . memberKey) sigs+ info = ClassInfo typRep sigMap+ maybeMarshalFunc = maybe (return nullFunPtr) marshalFunc+ metaDataPtr <- crlToNewArray return (mData moc)+ metaStrInfoPtr <- crlToNewArray return (mStrInfo moc)+ metaStrCharPtr <- crlToNewArray return (mStrChar moc)+ methodsPtr <- crlToNewArray maybeMarshalFunc (mFuncMethods moc)+ propsPtr <- crlToNewArray maybeMarshalFunc (mFuncProperties moc)+ maybeHndl <- hsqmlCreateClass+ metaDataPtr metaStrInfoPtr metaStrCharPtr info methodsPtr propsPtr+ case maybeHndl of+ Just hndl -> return hndl+ Nothing -> error ("Failed to create QML class '"++name++"'.")++implicitSignals :: [Member tt] -> [Member tt]+implicitSignals ms =+ let sigKeys = Set.fromList $ mapMaybe memberKey $+ filterMembers SignalMember ms+ impKeys = filter (flip Set.notMember sigKeys) $ mapMaybe memberKey $+ filterMembers PropertyMember ms+ impMember i k = Member SignalMember+ ("__implictSignal" ++ show i)+ tyVoid+ []+ (\_ _ -> return ())+ Nothing+ (Just k)+ in map (uncurry impMember) $ zip [0..] impKeys+ ----- ClassDef+-- Default Class -- --- | Generates a 'ClassDef' from a list of 'Member's.-defClass :: forall tt. (Object tt) => [Member tt] -> ClassDef tt-defClass = ClassDef- data MemoStore k v = MemoStore (MVar (Map k v)) (IORef (Map k v)) newMemoStore :: IO (MemoStore k v)@@ -230,110 +259,89 @@ writeIORef ir newMap return (newMap, (True, val)) -data ClassRec = ClassRec {- crecHndl :: HsQMLClassHandle,- crecSigs :: Map TypeRep Int-}+-- | The class 'DefaultClass' specifies a standard class definition for the+-- type @tt@.+class (Typeable tt) => DefaultClass tt where+ -- | List of default class members.+ classMembers :: [Member tt] -{-# NOINLINE classRecDb #-}-classRecDb :: MemoStore TypeRep ClassRec-classRecDb = unsafePerformIO $ newMemoStore+{-# NOINLINE defaultClassDb #-}+defaultClassDb :: MemoStore TypeRep HsQMLClassHandle+defaultClassDb = unsafePerformIO $ newMemoStore -getClassRec :: forall tt. (Object tt) => ClassDef tt -> IO ClassRec-getClassRec cdef = do+getDefaultClass :: forall tt. (DefaultClass tt) => IO (Class tt)+getDefaultClass = do let typ = typeOf (undefined :: tt)- (_, val) <- getFromMemoStore classRecDb typ (createClass typ cdef)- return val--createClass :: forall tt. (Object tt) => TypeRep -> ClassDef tt -> IO ClassRec-createClass typRep cdef = do- hsqmlInit- classId <- hsqmlGetNextClassId- let constrs t = typeRepTyCon t : (concatMap constrs $ typeRepArgs t)- name = foldr (\c s -> showString (tyConName c) .- showChar '_' . s) id (constrs typRep) $ showInt classId ""- ms = classMembers cdef- moc = compileClass name ms- sigs = filterMembers SignalMember ms- sigMap = Map.fromList $ flip zip [0..] $ map (fromJust . memberKey) sigs- maybeMarshalFunc = maybe (return nullFunPtr) marshalFunc- metaDataPtr <- crlToNewArray return (mData moc)- metaStrDataPtr <- crlToNewArray return (mStrData moc)- methodsPtr <- crlToNewArray maybeMarshalFunc (mFuncMethods moc)- propsPtr <- crlToNewArray maybeMarshalFunc (mFuncProperties moc)- maybeHndl <- hsqmlCreateClass- metaDataPtr metaStrDataPtr typRep methodsPtr propsPtr- case maybeHndl of- Just hndl -> return $ ClassRec hndl sigMap- Nothing -> error ("Failed to create QML class '"++name++"'.")+ (_, val) <- getFromMemoStore defaultClassDb typ $+ createClass typ (classMembers :: [Member tt])+ return (Class val) -- -- Method -- data MethodTypeInfo = MethodTypeInfo {- methodParamTypes :: [TypeName],- methodReturnType :: TypeName+ methodParamTypes :: [TypeId],+ methodReturnType :: TypeId } -newtype MSHelp a = MSHelp a- -- | Supports marshalling Haskell functions with an arbitrary number of -- arguments. class MethodSuffix a where mkMethodFunc :: Int -> a -> Ptr (Ptr ()) -> ErrIO () mkMethodTypes :: Tagged a MethodTypeInfo -instance (Marshal a, MarshalToHs (MarshalMode a), MethodSuffix (MSHelp b)) =>- MethodSuffix (MSHelp (a -> b)) where- mkMethodFunc n (MSHelp f) pv = do+instance (Marshal a, CanGetFrom a ~ Yes, MethodSuffix b) =>+ MethodSuffix (a -> b) where+ mkMethodFunc n f pv = do ptr <- errIO $ peekElemOff pv n- val <- mValToHs ptr- mkMethodFunc (n+1) (MSHelp $ f val) pv+ val <- mFromCVal ptr+ mkMethodFunc (n+1) (f val) pv return () mkMethodTypes = let (MethodTypeInfo p r) =- untag (mkMethodTypes :: Tagged (MSHelp b) MethodTypeInfo)- typ = untag (mTypeName :: Tagged a TypeName)+ untag (mkMethodTypes :: Tagged b MethodTypeInfo)+ typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ MethodTypeInfo (typ:p) r -instance (Marshal a, MarshalToValRaw (MarshalMode a)) =>- MethodSuffix (MSHelp (IO a)) where- mkMethodFunc _ (MSHelp f) pv = errIO $ do+instance (Marshal a, CanReturnTo a ~ Yes) =>+ MethodSuffix (IO a) where+ mkMethodFunc _ f pv = errIO $ do ptr <- peekElemOff pv 0 val <- f if nullPtr == ptr then return ()- else mHsToVal val ptr+ else mToCVal val ptr mkMethodTypes =- let typ = untag (mTypeName :: Tagged a TypeName)+ let typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ MethodTypeInfo [] typ mkUniformFunc :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) =>+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,+ MethodSuffix ms) => (tt -> ms) -> UniformFunc mkUniformFunc f = \pt pv -> do- hndl <- hsqmlGetObjectHandle pt- this <- mObjToHs hndl- runErrIO $ mkMethodFunc 1 (MSHelp $ f this) pv+ hndl <- hsqmlGetObjectFromPointer pt+ this <- mFromHndl hndl+ runErrIO $ mkMethodFunc 1 (f this) pv newtype VoidIO = VoidIO {runVoidIO :: (IO ())} -instance MethodSuffix (MSHelp VoidIO) where- mkMethodFunc _ (MSHelp f) pv = errIO $ runVoidIO f- mkMethodTypes = Tagged $ MethodTypeInfo [] (TypeName "")+instance MethodSuffix VoidIO where+ mkMethodFunc _ f pv = errIO $ runVoidIO f+ mkMethodTypes = Tagged $ MethodTypeInfo [] tyVoid class IsVoidIO a instance (IsVoidIO b) => IsVoidIO (a -> b) instance IsVoidIO VoidIO mkSpecialFunc :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms),- IsVoidIO ms) => (tt -> ms) -> UniformFunc+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,+ MethodSuffix ms, IsVoidIO ms) => (tt -> ms) -> UniformFunc mkSpecialFunc f = \pt pv -> do- hndl <- hsqmlGetObjectHandle pt- this <- mObjToHs hndl- runErrIO $ mkMethodFunc 0 (MSHelp $ f this) pv+ hndl <- hsqmlGetObjectFromPointer pt+ this <- mFromHndl hndl+ runErrIO $ mkMethodFunc 0 (f this) pv -- | Defines a named method using a function @f@ in the IO monad. --@@ -342,10 +350,10 @@ -- there may be zero or more parameter arguments followed by an optional return -- argument in the IO monad. defMethod :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) =>- String -> (tt -> ms) -> Member (ThisObj tt)+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, MethodSuffix ms) =>+ String -> (tt -> ms) -> Member (GetObjType tt) defMethod name f =- let crude = untag (mkMethodTypes :: Tagged (MSHelp ms) MethodTypeInfo)+ let crude = untag (mkMethodTypes :: Tagged ms MethodTypeInfo) in Member MethodMember name (methodReturnType crude)@@ -354,105 +362,99 @@ Nothing Nothing ------ Property------- | Defines a named read-only property using an accessor function in the IO--- monad.-defPropertyRO ::- forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),- Marshal tr, MarshalToVal (MarshalMode tr)) =>- String -> (tt -> IO tr) -> Member (ThisObj tt)-defPropertyRO name g = Member PropertyMember- name- (untag (mTypeName :: Tagged tr TypeName))- []- (mkUniformFunc g)- Nothing- Nothing---- | Defines a named read-write property using a pair of accessor and mutator--- functions in the IO monad.-defPropertyRW ::- forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),- Marshal tr, MarshalToHs (MarshalMode tr), MarshalToVal (MarshalMode tr)) =>- String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (ThisObj tt)-defPropertyRW name g s = Member PropertyMember- name- (untag (mTypeName :: Tagged tr TypeName))- []- (mkUniformFunc g)- (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))- Nothing+-- | Alias of 'defMethod' which is less polymorphic to reduce the need for type+-- signatures.+defMethod' :: forall obj ms. (Typeable obj, MethodSuffix ms) =>+ String -> (ObjRef obj -> ms) -> Member obj+defMethod' = defMethod -- -- Signal -- data SignalTypeInfo = SignalTypeInfo {- signalParamTypes :: [TypeName]+ signalParamTypes :: [TypeId] } --- | Defines a named signal using a 'SignalKey'.+-- | Defines a named signal. The signal is identified in subsequent calls to+-- 'fireSignal' using a 'SignalKeyValue'. This can be either i) type-based+-- using 'Proxy' @sk@ where @sk@ is an instance of the 'SignalKeyClass' class+-- or ii) data-based using a 'SignalKey' value creating using 'newSignalKey'. defSignal ::- forall obj sk. (Object obj, SignalKey sk) => Tagged sk String -> Member obj-defSignal tn =- let crude = untag (mkSignalTypes :: Tagged (SignalParams sk) SignalTypeInfo)- in Member SignalMember- (untag tn)- (TypeName "")- (signalParamTypes crude)- (\_ _ -> return ())- Nothing- (Just $ typeOf (undefined :: sk))+ forall obj skv. (SignalKeyValue skv) => String -> skv -> Member obj+defSignal name key =+ let crude = untag (mkSignalTypes ::+ Tagged (SignalValueParams skv) SignalTypeInfo)+ in Member SignalMember+ name+ tyVoid+ (signalParamTypes crude)+ (\_ _ -> return ())+ Nothing+ (Just $ signalKey key) --- | Fires a signal on an 'Object', specified using a 'SignalKey'.+-- | Fires a signal on an 'Object', specified using a 'SignalKeyValue'. fireSignal ::- forall tt sk. (- Marshal tt, MarshalToObj (MarshalMode tt),- Object (ThisObj tt), SignalKey sk) =>- Tagged sk tt -> SignalParams sk -fireSignal this =- let start cnt = do- crec <- getClassRec (classDef :: ClassDef (ThisObj tt))- let keyRep = typeOf (undefined :: sk)- slotMay = Map.lookup keyRep $ crecSigs crec+ forall tt skv. (Marshal tt, CanPassTo tt ~ Yes, IsObjType tt ~ Yes,+ SignalKeyValue skv) => skv -> tt -> SignalValueParams skv+fireSignal key this =+ let start cnt = postJob $ do+ hndl <- mToHndl this+ info <- hsqmlObjectGetHsTyperep hndl+ let slotMay = Map.lookup (signalKey key) $ cinfoSignals info case slotMay of- Just slotIdx -> postJob $ do- hndl <- mHsToObj $ untag this+ Just slotIdx -> withActiveObject hndl $ cnt $ SignalData hndl slotIdx Nothing ->- error ("Attempt to fire undefined signal on class '"++- (typeName $ untag (mTypeName :: Tagged tt TypeName))++"'.")- cont ps (SignalData hndl slotIdx) =- withArray (nullPtr:ps) (\pptr ->+ return () -- Should warn?+ cont ps (SignalData hndl slotIdx) =+ withArray (nullPtr:ps) (\pptr -> hsqmlFireSignal hndl slotIdx pptr) in mkSignalArgs start cont data SignalData = SignalData HsQMLObjectHandle Int --- | Instances of the 'SignalKey' class identify distinct signals. The--- associated 'SignalParams' type specifies the signal's signature.-class (SignalSuffix (SignalParams sk), Typeable sk) => SignalKey sk where- type SignalParams sk+-- | Values of the type 'SignalKey' identify distinct signals by value. The+-- type parameter @p@ specifies the signal's signature.+newtype SignalKey p = SignalKey Unique +-- | Creates a new 'SignalKey'. +newSignalKey :: (SignalSuffix p) => IO (SignalKey p)+newSignalKey = fmap SignalKey $ newUnique++-- | Instances of the 'SignalKeyClass' class identify distinct signals by type.+-- The associated 'SignalParams' type specifies the signal's signature.+class (SignalSuffix (SignalParams sk)) => SignalKeyClass sk where+ type SignalParams sk++class (SignalSuffix (SignalValueParams skv)) => SignalKeyValue skv where+ type SignalValueParams skv+ signalKey :: skv -> MemberKey++instance (SignalKeyClass sk, Typeable sk) => SignalKeyValue (Proxy sk) where+ type SignalValueParams (Proxy sk) = SignalParams sk+ signalKey _ = TypeKey $ typeOf (undefined :: sk)++instance (SignalSuffix p) => SignalKeyValue (SignalKey p) where+ type SignalValueParams (SignalKey p) = p+ signalKey (SignalKey u) = DataKey u+ -- | Supports marshalling an arbitrary number of arguments into a QML signal. class SignalSuffix ss where mkSignalArgs :: forall usr. ((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss mkSignalTypes :: Tagged ss SignalTypeInfo -instance (Marshal a, MarshalToVal (MarshalMode a), SignalSuffix b) =>+instance (Marshal a, CanPassTo a ~ Yes, SignalSuffix b) => SignalSuffix (a -> b) where mkSignalArgs start cont param = mkSignalArgs start (\ps usr ->- mHsToAlloc param (\ptr ->+ mWithCVal param (\ptr -> cont (ptr:ps) usr)) mkSignalTypes = let (SignalTypeInfo p) = untag (mkSignalTypes :: Tagged b SignalTypeInfo)- typ = untag (mTypeName :: Tagged a TypeName)+ typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ SignalTypeInfo (typ:p) instance SignalSuffix (IO ()) where@@ -460,3 +462,91 @@ start $ cont [] mkSignalTypes = Tagged $ SignalTypeInfo []++--+-- Property+--++-- | Defines a named read-only property using an accessor function in the IO+-- monad.+defPropertyRO :: forall tt tr.+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes) => String ->+ (tt -> IO tr) -> Member (GetObjType tt)+defPropertyRO name g = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ Nothing+ Nothing++-- | Defines a named read-only property with an associated signal.+defPropertySigRO :: forall tt tr skv.+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes, SignalKeyValue skv) => String -> skv ->+ (tt -> IO tr) -> Member (GetObjType tt)+defPropertySigRO name key g = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ Nothing+ (Just $ signalKey key)++-- | Defines a named read-write property using a pair of accessor and mutator+-- functions in the IO monad.+defPropertyRW :: forall tt tr.+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) => String ->+ (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt)+defPropertyRW name g s = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))+ Nothing++-- | Defines a named read-write property with an associated signal.+defPropertySigRW :: forall tt tr skv.+ (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes, SignalKeyValue skv) =>+ String -> skv -> (tt -> IO tr) -> (tt -> tr -> IO ()) ->+ Member (GetObjType tt)+defPropertySigRW name key g s = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))+ (Just $ signalKey key)++-- | Alias of 'defPropertyRO' which is less polymorphic to reduce the need for+-- type signatures.+defPropertyRO' :: forall obj tr.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>+ String -> (ObjRef obj -> IO tr) -> Member obj+defPropertyRO' = defPropertyRO++-- | Alias of 'defPropertySigRO' which is less polymorphic to reduce the need+-- for type signatures.+defPropertySigRO' :: forall obj tr skv.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, SignalKeyValue skv) =>+ String -> skv -> (ObjRef obj -> IO tr) -> Member obj+defPropertySigRO' = defPropertySigRO++-- | Alias of 'defPropertyRW' which is less polymorphic to reduce the need for+-- type signatures.+defPropertyRW' :: forall obj tr.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) =>+ String -> (ObjRef obj -> IO tr) -> (ObjRef obj -> tr -> IO ()) -> Member obj+defPropertyRW' = defPropertyRW++-- | Alias of 'defPropertySigRW' which is less polymorphic to reduce the need+-- for type signatures.+defPropertySigRW' :: forall obj tr skv.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes,+ SignalKeyValue skv) => String -> skv ->+ (ObjRef obj -> IO tr) -> (ObjRef obj -> tr -> IO ()) -> Member obj+defPropertySigRW' = defPropertySigRW
+ test/Graphics/QML/Test/DataTest.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}++module Graphics.QML.Test.DataTest where++import Graphics.QML.Marshal+import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Arbitrary+import Control.Applicative+import Data.Typeable++data DataTest a+ = DTCallMethod a+ | DTMethodRet a+ | DTReadProp a+ | DTWriteProp a+ deriving (Eq, Show, Typeable)++instance (Eq a, Show a, Typeable a, S.Literal a, Arbitrary a, MakeDefault a,+ Marshal a, CanPassTo a ~ Yes, CanReturnTo a ~ Yes, CanGetFrom a ~ Yes)+ => TestAction (DataTest a) where+ legalActionIn _ _ = True + nextActionsFor _ = mayOneof [+ DTCallMethod <$> fromGen arbitrary,+ DTMethodRet <$> fromGen arbitrary,+ DTReadProp <$> fromGen arbitrary,+ DTWriteProp <$> fromGen arbitrary]+ updateEnvRaw _ = testEnvStep+ actionRemote (DTCallMethod v) n =+ S.eval $ S.var n `S.dot` "callMethod" `S.call` [S.literal v]+ actionRemote (DTMethodRet v) n =+ S.assert $ S.deepEq (S.var n `S.dot` "methodRet" `S.call` []) $+ S.literal v+ actionRemote (DTReadProp v) n =+ S.assert $ S.deepEq (S.var n `S.dot` "readProp") $ S.literal v+ actionRemote (DTWriteProp v) n =+ S.var n `S.dot` "writeProp" `S.set` S.literal v+ mockObjDef = [+ defMethod "methodRet" $ \m -> expectAction m $ \a -> case a of+ DTMethodRet v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "callMethod" $ \m v ->+ checkAction m (DTCallMethod v) $ return (),+ defPropertyRW "readProp"+ (\m -> expectAction m $ \a -> case a of+ DTReadProp v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "writeProp"+ (\_ -> makeDef) (\m v -> checkAction m (DTWriteProp v) $ return ())]
test/Graphics/QML/Test/Framework.hs view
@@ -26,7 +26,6 @@ import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI data TestType = forall a. (TestAction a) => TestType (Proxy a) @@ -203,11 +202,14 @@ makeDef = do statusRef <- newIORef $ TestStatus [] (Just TInvalid) (TestEnv badSerial IntMap.empty IntMap.empty) IntMap.empty- newObject $ MockObj badSerial statusRef+ newObjectDC $ MockObj badSerial statusRef instance MakeDefault () where makeDef = return () +instance MakeDefault Bool where+ makeDef = return False+ instance MakeDefault Int32 where makeDef = return 0 @@ -220,8 +222,8 @@ instance MakeDefault Text where makeDef = return T.empty -instance MakeDefault URI where- makeDef = return $ URI "" Nothing "" "" ""+instance MakeDefault (Maybe a) where+ makeDef = return Nothing expectAction :: (TestAction a, MakeDefault b) => MockObj a -> (a -> IO (Either TestFault b)) -> IO b@@ -248,6 +250,17 @@ ObjRef (MockObj a) -> (a -> IO (Either TestFault b)) -> IO b expectActionRef ref pred = expectAction (fromObjRef ref) pred +checkAction :: (TestAction a, Eq a, MakeDefault b) =>+ MockObj a -> a -> IO b -> IO b+checkAction mock action next = expectAction mock $ \expected -> do+ if expected == action+ then fmap Right $ next+ else return . Left $+ if fakeToConstr expected /= fakeToConstr action+ then TBadActionCtor+ else TBadActionData+ where fakeToConstr = takeWhile (/= ' ') . show+ badAction :: (MakeDefault b) => MockObj a -> IO b badAction mock = do status <- readIORef $ mockStatus mock@@ -257,7 +270,7 @@ forkMockObj :: (TestAction b) => MockObj a -> IO (ObjRef (MockObj b)) forkMockObj m = do status <- mockGetStatus m- newObject $ MockObj (testSerial status) $ mockStatus m+ newObjectDC $ MockObj (testSerial status) $ mockStatus m checkMockObj :: forall a b. (TestAction b) => MockObj a -> MockObj b -> Int -> IO (Either TestFault ())@@ -269,9 +282,9 @@ else return $ Left TBadActionData _ -> return $ Left TBadActionSlot -instance (TestAction a) => Object (MockObj a) where- classDef = defClass mockObjDef+instance (TestAction a) => DefaultClass (MockObj a) where+ classMembers = mockObjDef instance (TestAction a) => Marshal (MockObj a) where- type MarshalMode (MockObj a) = ValObjToOnly (MockObj a)- marshaller = objSimpleMarshaller+ type MarshalMode (MockObj a) c d = ModeObjFrom (MockObj a) c+ marshaller = fromMarshaller fromObjRef
− test/Graphics/QML/Test/GenURI.hs
@@ -1,51 +0,0 @@-module Graphics.QML.Test.GenURI where--import Test.QuickCheck.Gen-import Network.URI-import Numeric--capSize :: Int -> Gen a -> Gen a-capSize cap g = sized (\s -> if s > cap then resize cap g else resize s g)--uriGen :: Gen URI-uriGen = capSize 35 $ do- let slists = fmap (:[])- listxyz = fmap concat . sequence- listxs = fmap concat . listOf- listxs1 = fmap concat . listOf1- lower = elements $ slists $ enumFromTo 'a' 'z'- upper = elements $ slists $ enumFromTo 'A' 'Z'- digit = elements $ slists "01234567989"- mark = elements $ slists "-_.!~*'()"- sextra = elements $ slists "+-."- rextra = elements $ slists "$,;:@&=+"- dash = return "-"- dot = return "."- alpha = oneof [lower, upper]- alphnum = oneof [lower, upper, digit]- dchar = oneof [lower, digit]- dchar2 = frequency [(9,lower), (5,digit), (1,dash)]- unres = frequency [(9,alphnum), (1,mark)]- escNum = oneof [choose (0,31), choose (128,255)] :: Gen Int- pad = \n x -> replicate (n - length x) '0' ++ x- escape = fmap (('%':) . pad 2 . flip showHex "") escNum- scheme = listxyz [alpha, listxs $ frequency [- (9,alphnum), (1,sextra)]]- dpart1 = listxyz [- frequency [(9,dchar), (1,listxyz [dchar, dot, dchar])],- listxs $ frequency [- (9,dchar2), (1,listxyz [dchar, dot, dchar]),- (1,listxyz [dchar, dot, dchar, dot, dchar])],- dchar, dot]- dpart2 = oneof [lower, listxyz [lower, listxs dchar2, dchar]]- regName = flip suchThat (\x -> length x < 255) $ listxyz [- frequency [(9,dpart1), (1,return "")],- dpart2, oneof [dot, return ""]]- segment = fmap ('/':) $ listxs $ frequency [- (9,unres), (1,escape), (1,rextra)]- path = listxs1 segment- schemeStr <- scheme- regNameStr <- regName- pathStr <- path- return $- URI (schemeStr++":") (Just $ URIAuth "" regNameStr "") pathStr "" ""
test/Graphics/QML/Test/Harness.hs view
@@ -16,12 +16,20 @@ qmlPrelude :: String qmlPrelude = unlines [- "import Qt 4.7",- "Rectangle {",- " id: page;",- " width: 100; height: 100;",- " color: 'green';",- " Component.onCompleted: {"]+ "import QtQuick 2.0",+ "import QtQuick.Window 2.0",+ "Window {",+ " id: page; visible: false;",+ " Component.onCompleted: {",+ " function deepEq(a, b) {",+ " if (a === b) {return true;}",+ " if (typeof a == 'object' && typeof b == 'object') {",+ " var ak = Object.keys(a); var bk = Object.keys(b);",+ " if (ak.length != bk.length) {return false;}",+ " for (var i=0; i<ak.length; i++) {",+ " if (!deepEq(a[ak[i]], b[ak[i]])) {return false;}}",+ " return true;}",+ " return false;}"] qmlPostscript :: String qmlPostscript = unlines [@@ -46,10 +54,9 @@ hPutStr hndl (qmlPrelude ++ js ++ qmlPostscript) hClose hndl mock <- mockFromSrc src- go <- newObject mock+ go <- newObjectDC mock runEngineLoop defaultEngineConfig {- initialURL = filePathToURI qmlPath,- initialWindowState = HideWindow,+ initialDocument = fileDocument qmlPath, contextObject = Just $ anyObjRef go} removeFile qmlPath finishTest mock@@ -65,10 +72,11 @@ assert $ isNothing $ testFault status return () -checkProperty :: TestType -> IO Bool-checkProperty (TestType pxy) = do+checkProperty :: Int -> TestType -> IO Bool+checkProperty n (TestType pxy) = do putStrLn $ "Checking " ++ show (typeOf $ asProxyTypeOf undefined pxy)- r <- quickCheckResult $ testProperty . constrainSrc pxy+ let args = stdArgs {maxSuccess = n}+ r <- quickCheckWithResult args $ testProperty . constrainSrc pxy return $ isSuccess r constrainSrc :: (TestAction a) => Proxy a -> TestBoxSrc a -> TestBoxSrc a
test/Graphics/QML/Test/ScriptDSL.hs view
@@ -8,7 +8,6 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T-import Network.URI import Numeric data Expr = Global | Expr {unExpr :: ShowS}@@ -25,6 +24,10 @@ class Literal a where literal :: a -> Expr +instance Literal Bool where+ literal True = Expr $ showString "true"+ literal False = Expr $ showString "false"+ instance Literal Int where literal x = Expr $ shows x @@ -38,10 +41,10 @@ | isNegativeZero x = Expr $ showString "-0" | otherwise = Expr $ shows x -instance Literal [Char] where- literal [] = Expr $ showString "\"\""- literal cs =- Expr (showChar '"' . (foldr1 (.) $ map f cs) . showChar '"')+instance Literal Text where+ literal txt =+ Expr (showChar '"' . (+ foldr (.) id . map f $ T.unpack txt) . showChar '"') where f '\"' = showString "\\\"" f '\\' = showString "\\\\" f c | ord c < 32 = hexEsc c@@ -51,11 +54,14 @@ in showString "\\u" . showString ( replicate (4 - (length $ h "")) '0') . h -instance Literal Text where- literal = literal . T.unpack+instance Literal a => Literal (Maybe a) where+ literal Nothing = Expr $ showString "null"+ literal (Just v) = literal v -instance Literal URI where- literal = literal . ($ "") . uriToString id+instance Literal a => Literal [a] where+ literal xs = Expr (showChar '[' . (+ foldr (.) id . intersperse (showChar ',') $ map (unExpr . literal) xs) .+ showChar ']') var :: Int -> Expr var 0 = Global@@ -71,7 +77,7 @@ call :: Expr -> [Expr] -> Expr call (Expr f) ps = Expr ( f . showChar '(' . (- foldr1 (.) $ (id:) $ intersperse (showChar ',') $ map unExpr ps) .+ foldr (.) id $ intersperse (showChar ',') $ map unExpr ps) . showChar ')') call _ _ = error "cannot call the context object" @@ -86,6 +92,9 @@ neq :: Expr -> Expr -> Expr neq = binOp " != " +deepEq :: Expr -> Expr -> Expr+deepEq a b = call (sym "deepEq") [a, b]+ eval :: Expr -> Prog eval (Expr ex) = Prog (ex . showString ";\n") id eval _ = error "cannot eval the context object"@@ -104,7 +113,7 @@ assert :: Expr -> Prog assert (Expr ex) = Prog (showString "if (!" . ex .- showString ") {window.close(); throw -1;}\n") id+ showString ") {Qt.quit(); throw -1;}\n") id assert _ = error "cannot assert the context object" connect :: Expr -> Expr -> Prog@@ -127,4 +136,4 @@ callee = sym "arguments.callee" end :: Prog-end = Prog (showString "window.close();\n") id+end = Prog (showString "Qt.quit();\n") id
test/Graphics/QML/Test/SignalTest.hs view
@@ -5,7 +5,6 @@ import Graphics.QML.Objects import Graphics.QML.Test.Framework import Graphics.QML.Test.MayGen-import Graphics.QML.Test.GenURI import Graphics.QML.Test.TestObject import Graphics.QML.Test.ScriptDSL (Expr, Prog) import qualified Graphics.QML.Test.ScriptDSL as S@@ -13,13 +12,12 @@ import Test.QuickCheck.Arbitrary import Control.Applicative import Data.Monoid-import Data.Tagged+import Data.Proxy import Data.Typeable import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI data SignalTest1 = ST1TrivialMethod@@ -27,51 +25,39 @@ | ST1FireInt Int32 | ST1FireThreeInts Int32 Int32 Int32 | ST1FireDouble Double- | ST1FireString String | ST1FireText Text- | ST1FireURI URI | ST1FireObject Int | ST1CheckObject Int deriving (Show, Typeable) data NoArgsSignal deriving Typeable -instance SignalKey NoArgsSignal where+instance SignalKeyClass NoArgsSignal where type SignalParams NoArgsSignal = IO () data IntSignal deriving Typeable -instance SignalKey IntSignal where+instance SignalKeyClass IntSignal where type SignalParams IntSignal = Int32 -> IO () data ThreeIntsSignal deriving Typeable -instance SignalKey ThreeIntsSignal where+instance SignalKeyClass ThreeIntsSignal where type SignalParams ThreeIntsSignal = Int32 -> Int32 -> Int32 -> IO () data DoubleSignal deriving Typeable -instance SignalKey DoubleSignal where+instance SignalKeyClass DoubleSignal where type SignalParams DoubleSignal = Double -> IO () -data StringSignal deriving Typeable--instance SignalKey StringSignal where- type SignalParams StringSignal = String -> IO ()- data TextSignal deriving Typeable -instance SignalKey TextSignal where+instance SignalKeyClass TextSignal where type SignalParams TextSignal = Text -> IO () -data URISignal deriving Typeable--instance SignalKey URISignal where- type SignalParams URISignal = URI -> IO ()- data ObjectSignal deriving Typeable -instance SignalKey ObjectSignal where+instance SignalKeyClass ObjectSignal where type SignalParams ObjectSignal = ObjRef (MockObj TestObject) -> IO () chainSignal :: Int -> [String] -> String -> String -> Prog@@ -94,9 +80,7 @@ ST1FireThreeInts <$> fromGen arbitrary <*> fromGen arbitrary <*> fromGen arbitrary, ST1FireDouble <$> fromGen arbitrary,- ST1FireString <$> fromGen arbitrary, ST1FireText . T.pack <$> fromGen arbitrary,- ST1FireURI <$> fromGen uriGen, pure . ST1FireObject $ testEnvNextJ env, ST1CheckObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (ST1FireObject n) = testEnvStep . testEnvSerial (\s ->@@ -116,12 +100,8 @@ (S.assert $ S.sym "arg3" `S.eq` S.literal v3) actionRemote (ST1FireDouble v) n = testSignal n "doubleSignal" "fireDouble" $ S.literal v- actionRemote (ST1FireString v) n =- testSignal n "stringSignal" "fireString" $ S.literal v actionRemote (ST1FireText v) n = testSignal n "textSignal" "fireText" $ S.literal v- actionRemote (ST1FireURI v) n =- testSignal n "uriSignal" "fireURI" $ S.literal v actionRemote (ST1FireObject v) n = chainSignal n ["obj"] "objectSignal" "fireObject" `mappend` (S.saveVar v $ S.sym "obj")@@ -133,63 +113,41 @@ _ -> return $ Left TBadActionCtor, defMethod "fireNoArgs" $ \m -> (expectActionRef m $ \a -> case a of ST1FireNoArgs -> do- fireSignal (Tagged m- :: Tagged NoArgsSignal (ObjRef (MockObj SignalTest1)))+ fireSignal (Proxy :: Proxy NoArgsSignal) m return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "noArgsSignal" :: Tagged NoArgsSignal String), + defSignal "noArgsSignal" (Proxy :: Proxy NoArgsSignal), defMethod "fireInt" $ \m -> (expectActionRef m $ \a -> case a of ST1FireInt v -> do- fireSignal (Tagged m- :: Tagged IntSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy IntSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "intSignal" :: Tagged IntSignal String),+ defSignal "intSignal" (Proxy :: Proxy IntSignal), defMethod "fireThreeInts" $ \m -> (expectActionRef m $ \a -> case a of ST1FireThreeInts v1 v2 v3 -> do- fireSignal (Tagged m- :: Tagged ThreeIntsSignal (ObjRef (MockObj SignalTest1)))- v1 v2 v3+ fireSignal (Proxy :: Proxy ThreeIntsSignal) m v1 v2 v3 return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "threeIntsSignal" ::- Tagged ThreeIntsSignal String),+ defSignal "threeIntsSignal" (Proxy :: Proxy ThreeIntsSignal), defMethod "fireDouble" $ \m -> (expectActionRef m $ \a -> case a of ST1FireDouble v -> do- fireSignal (Tagged m- :: Tagged DoubleSignal (ObjRef (MockObj SignalTest1))) v- return $ Right ()- _ -> return $ Left TBadActionCtor),- defSignal (Tagged "doubleSignal" :: Tagged DoubleSignal String),- defMethod "fireString" $ \m -> (expectActionRef m $ \a -> case a of- ST1FireString v -> do- fireSignal (Tagged m- :: Tagged StringSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy DoubleSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "stringSignal" :: Tagged StringSignal String),+ defSignal "doubleSignal" (Proxy :: Proxy DoubleSignal), defMethod "fireText" $ \m -> (expectActionRef m $ \a -> case a of ST1FireText v -> do- fireSignal (Tagged m- :: Tagged TextSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy TextSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "textSignal" :: Tagged TextSignal String),- defMethod "fireURI" $ \m -> (expectActionRef m $ \a -> case a of- ST1FireURI v -> do- fireSignal (Tagged m- :: Tagged URISignal (ObjRef (MockObj SignalTest1))) v- return $ Right ()- _ -> return $ Left TBadActionCtor),- defSignal (Tagged "uriSignal" :: Tagged URISignal String),+ defSignal "textSignal" (Proxy :: Proxy TextSignal), defMethod "fireObject" $ \m -> (expectActionRef m $ \a -> case a of ST1FireObject _ -> do (Right obj) <- getTestObject $ fromObjRef m- fireSignal (Tagged m- :: Tagged ObjectSignal (ObjRef (MockObj SignalTest1))) obj+ fireSignal (Proxy :: Proxy ObjectSignal) m obj return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "objectSignal" :: Tagged ObjectSignal String),+ defSignal "objectSignal" (Proxy :: Proxy ObjectSignal), defMethod "checkObject" $ \m v -> expectAction m $ \a -> case a of ST1CheckObject w -> setTestObject m v w _ -> return $ Left TBadActionCtor]
test/Graphics/QML/Test/SimpleTest.hs view
@@ -5,7 +5,6 @@ import Graphics.QML.Objects import Graphics.QML.Test.Framework import Graphics.QML.Test.MayGen-import Graphics.QML.Test.GenURI import Graphics.QML.Test.TestObject import Graphics.QML.Test.ScriptDSL (Expr, Prog) import qualified Graphics.QML.Test.ScriptDSL as S@@ -17,7 +16,6 @@ import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI makeCall :: Int -> String -> [Expr] -> Prog makeCall n name es = S.eval $ S.var n `S.dot` name `S.call` es@@ -41,6 +39,9 @@ checkArg v w = return $ if v == w then Right () else Left TBadActionData +retVoid :: IO ()+retVoid = return ()+ data SimpleMethods = SMTrivial | SMTernary Int32 Int32 Int32 Int32@@ -48,15 +49,11 @@ | SMSetInt Int32 | SMGetDouble Double | SMSetDouble Double- | SMGetString String- | SMSetString String | SMGetText Text | SMSetText Text- | SMGetURI URI- | SMSetURI URI | SMGetObject Int | SMSetObject Int- deriving (Show, Typeable)+ deriving (Eq, Show, Typeable) instance TestAction SimpleMethods where legalActionIn (SMSetObject n) env = testEnvIsaJ n testObjectType env@@ -70,12 +67,8 @@ SMSetInt <$> fromGen arbitrary, SMGetDouble <$> fromGen arbitrary, SMSetDouble <$> fromGen arbitrary,- SMGetString <$> fromGen arbitrary,- SMSetString <$> fromGen arbitrary, SMGetText . T.pack <$> fromGen arbitrary, SMSetText . T.pack <$> fromGen arbitrary,- SMGetURI <$> fromGen uriGen,- SMSetURI <$> fromGen uriGen, pure . SMGetObject $ testEnvNextJ env, SMSetObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (SMGetObject n) = testEnvStep . testEnvSerial (\s ->@@ -88,18 +81,12 @@ actionRemote (SMSetInt v) n = makeCall n "setInt" [S.literal v] actionRemote (SMGetDouble v) n = testCall n "getDouble" [] $ S.literal v actionRemote (SMSetDouble v) n = makeCall n "setDouble" [S.literal v]- actionRemote (SMGetString v) n = testCall n "getString" [] $ S.literal v- actionRemote (SMSetString v) n = makeCall n "setString" [S.literal v] actionRemote (SMGetText v) n = testCall n "getText" [] $ S.literal v actionRemote (SMSetText v) n = makeCall n "setText" [S.literal v]- actionRemote (SMGetURI v) n = testCall n "getURI" [] $ S.literal v- actionRemote (SMSetURI v) n = makeCall n "setURI" [S.literal v] actionRemote (SMGetObject v) n = saveCall v n "getObject" [] actionRemote (SMSetObject v) n = makeCall n "setObject" [S.var v] mockObjDef = [- defMethod "trivial" $ \m -> expectAction m $ \a -> case a of- SMTrivial -> return $ Right ()- _ -> return $ Left TBadActionCtor,+ defMethod "trivial" $ \m -> checkAction m SMTrivial retVoid, defMethod "ternary" $ \m v1 v2 v3 -> expectAction m $ \a -> case a of SMTernary w1 w2 w3 w4 -> (fmap . fmap) (const w4) $ checkArg (v1,v2,v3) (w1,w2,w3)@@ -107,33 +94,15 @@ defMethod "getInt" $ \m -> expectAction m $ \a -> case a of SMGetInt v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setInt" $ \m v -> expectAction m $ \a -> case a of- SMSetInt w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setInt" $ \m v -> checkAction m (SMSetInt v) retVoid, defMethod "getDouble" $ \m -> expectAction m $ \a -> case a of SMGetDouble v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setDouble" $ \m v -> expectAction m $ \a -> case a of- SMSetDouble w -> checkArg v w- _ -> return $ Left TBadActionCtor,- defMethod "getString" $ \m -> expectAction m $ \a -> case a of- SMGetString v -> return $ Right v- _ -> return $ Left TBadActionCtor,- defMethod "setString" $ \m v -> expectAction m $ \a -> case a of- SMSetString w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setDouble" $ \m v -> checkAction m (SMSetDouble v) retVoid, defMethod "getText" $ \m -> expectAction m $ \a -> case a of SMGetText v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setText" $ \m v -> expectAction m $ \a -> case a of- SMSetText w -> checkArg v w- _ -> return $ Left TBadActionCtor,- defMethod "getURI" $ \m -> expectAction m $ \a -> case a of- SMGetURI v -> return $ Right v- _ -> return $ Left TBadActionCtor,- defMethod "setURI" $ \m v -> expectAction m $ \a -> case a of- SMSetURI w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setText" $ \m v -> checkAction m (SMSetText v) retVoid, defMethod "getObject" $ \m -> expectAction m $ \a -> case a of SMGetObject _ -> getTestObject m _ -> return $ Left TBadActionCtor,@@ -147,15 +116,11 @@ | SPSetInt Int32 | SPGetDouble Double | SPSetDouble Double- | SPGetString String- | SPSetString String | SPGetText Text | SPSetText Text- | SPGetURI URI- | SPSetURI URI | SPGetObject Int | SPSetObject Int- deriving (Show, Typeable)+ deriving (Eq, Show, Typeable) instance TestAction SimpleProperties where legalActionIn (SPSetObject n) env = testEnvIsaJ n testObjectType env@@ -166,12 +131,8 @@ SPSetInt <$> fromGen arbitrary, SPGetDouble <$> fromGen arbitrary, SPSetDouble <$> fromGen arbitrary,- SPGetString <$> fromGen arbitrary,- SPSetString <$> fromGen arbitrary, SPGetText . T.pack <$> fromGen arbitrary, SPSetText . T.pack <$> fromGen arbitrary,- SPGetURI <$> fromGen uriGen,- SPSetURI <$> fromGen uriGen, pure . SPGetObject $ testEnvNextJ env, SPSetObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (SPGetObject n) = testEnvStep . testEnvSerial (\s ->@@ -182,12 +143,8 @@ actionRemote (SPSetInt v) n = setProp n "propIntW" $ S.literal v actionRemote (SPGetDouble v) n = testProp n "propDoubleR" $ S.literal v actionRemote (SPSetDouble v) n = setProp n "propDoubleW" $ S.literal v- actionRemote (SPGetString v) n = testProp n "propStringR" $ S.literal v- actionRemote (SPSetString v) n = setProp n "propStringW" $ S.literal v actionRemote (SPGetText v) n = testProp n "propTextR" $ S.literal v actionRemote (SPSetText v) n = setProp n "propTextW" $ S.literal v- actionRemote (SPGetURI v) n = testProp n "propURIR" $ S.literal v- actionRemote (SPSetURI v) n = setProp n "propURIW" $ S.literal v actionRemote (SPGetObject v) n = saveProp v n "propObjectR" actionRemote (SPSetObject v) n = setProp n "propObjectW" $ S.var v mockObjDef = [@@ -203,50 +160,21 @@ _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propIntW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetInt w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetInt v) retVoid), defPropertyRW "propDoubleR" (\m -> expectAction m $ \a -> case a of SPGetDouble v -> return $ Right v _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propDoubleW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetDouble w -> checkArg v w- _ -> return $ Left TBadActionCtor),- defPropertyRW "propStringR"- (\m -> expectAction m $ \a -> case a of- SPGetString v -> return $ Right v- _ -> return $ Left TBadActionCtor)- (\m _ -> badAction m),- defPropertyRW "propStringW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetString w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetDouble v) retVoid), defPropertyRW "propTextR" (\m -> expectAction m $ \a -> case a of SPGetText v -> return $ Right v _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propTextW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetText w -> checkArg v w- _ -> return $ Left TBadActionCtor),- defPropertyRW "propURIR"- (\m -> expectAction m $ \a -> case a of- SPGetURI v -> return $ Right v- _ -> return $ Left TBadActionCtor)- (\m _ -> badAction m),- defPropertyRW "propURIW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetURI w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetText v) retVoid), defPropertyRW "propObjectR" (\m -> expectAction m $ \a -> case a of SPGetObject _ -> getTestObject m
test/Test1.hs view
@@ -4,19 +4,41 @@ import Graphics.QML.Test.Framework import Graphics.QML.Test.Harness+import Graphics.QML.Test.DataTest import Graphics.QML.Test.SimpleTest import Graphics.QML.Test.SignalTest import Graphics.QML.Test.MixedTest import Data.Proxy import System.Exit +import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Test.QuickCheck.Arbitrary++instance Arbitrary Text where+ arbitrary = fmap T.pack $ arbitrary+ shrink = map T.pack . shrink . T.unpack+ main :: IO () main = do rs <- sequence [- checkProperty $ TestType (Proxy :: Proxy SimpleMethods),- checkProperty $ TestType (Proxy :: Proxy SimpleProperties),- checkProperty $ TestType (Proxy :: Proxy SignalTest1),- checkProperty $ TestType (Proxy :: Proxy ObjectA)]+ checkProperty 100 $ TestType (Proxy :: Proxy SimpleMethods),+ checkProperty 100 $ TestType (Proxy :: Proxy SimpleProperties),+ checkProperty 100 $ TestType (Proxy :: Proxy SignalTest1),+ checkProperty 100 $ TestType (Proxy :: Proxy ObjectA),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest Bool)),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest Int32)),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest Double)),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest Text)),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Bool))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Int32))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Double))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Text))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Bool])),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Int32])),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Double])),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Text]))] if and rs then exitSuccess else exitFailure