diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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' diff --git a/cbits/Class.cpp b/cbits/Class.cpp new file mode 100644 --- /dev/null +++ b/cbits/Class.cpp @@ -0,0 +1,163 @@ +#include +#include +#include +#include +#include +#include + +#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 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(mMetaStrData.data()), + mMetaData, + 0, + 0}; + mMetaObject = metaObj; + + // Add reference + ref(Handle); + + gManager->updateCounter(HsQMLManager::ClassCount, 1); +} + +HsQMLClass::~HsQMLClass() +{ + for (int i=0; ifreeFun((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); +} diff --git a/cbits/Class.h b/cbits/Class.h new file mode 100644 --- /dev/null +++ b/cbits/Class.h @@ -0,0 +1,40 @@ +#ifndef HSQML_CLASS_H +#define HSQML_CLASS_H + +#include +#include +#include + +#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 mMetaStrData; + HsStablePtr mHsTypeRep; + int mMethodCount; + int mPropertyCount; + HsQMLUniformFunc* mMethods; + HsQMLUniformFunc* mProperties; + QMetaObject mMetaObject; +}; + +#endif /*HSQML_CLASS_H*/ diff --git a/cbits/Engine.cpp b/cbits/Engine.cpp new file mode 100644 --- /dev/null +++ b/cbits/Engine.cpp @@ -0,0 +1,107 @@ +#include +#include + +#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(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(obj); + QQuickItem* item = qobject_cast(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 errs = mComponent.errors(); + for (QList::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(contextObject); + config.initialURL = *reinterpret_cast(initialURL); + config.stopCb = stopCb; + + Q_ASSERT (gManager); + gManager->createEngine(config); +} diff --git a/cbits/Engine.h b/cbits/Engine.h new file mode 100644 --- /dev/null +++ b/cbits/Engine.h @@ -0,0 +1,48 @@ +#ifndef HSQML_ENGINE_H +#define HSQML_ENGINE_H + +#include +#include +#include +#include +#include +#include + +#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 mObjects; + HsQMLTrivialCb mStopCb; +}; + +#endif /*HSQML_ENGINE_H*/ diff --git a/cbits/HsQMLClass.cpp b/cbits/HsQMLClass.cpp deleted file mode 100644 --- a/cbits/HsQMLClass.cpp +++ /dev/null @@ -1,146 +0,0 @@ -#include -#include -#include -#include -#include - -#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; ifreeFun((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); -} diff --git a/cbits/HsQMLClass.h b/cbits/HsQMLClass.h deleted file mode 100644 --- a/cbits/HsQMLClass.h +++ /dev/null @@ -1,39 +0,0 @@ -#ifndef HSQML_CLASS_H -#define HSQML_CLASS_H - -#include -#include - -#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*/ diff --git a/cbits/HsQMLEngine.cpp b/cbits/HsQMLEngine.cpp deleted file mode 100644 --- a/cbits/HsQMLEngine.cpp +++ /dev/null @@ -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(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(contextObject); - config.initialURL = *reinterpret_cast(initialURL); - config.showWindow = static_cast(showWindow); - if (setWindowTitle) { - config.setWindowTitle = true; - config.windowTitle = *reinterpret_cast(windowTitle); - } - config.stopCb = stopCb; - - Q_ASSERT (gManager); - gManager->createEngine(config); -} diff --git a/cbits/HsQMLEngine.h b/cbits/HsQMLEngine.h deleted file mode 100644 --- a/cbits/HsQMLEngine.h +++ /dev/null @@ -1,68 +0,0 @@ -#ifndef HSQML_ENGINE_H -#define HSQML_ENGINE_H - -#include -#include -#include -#include -#include -#include -#include - -#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 mContextObj; - HsQMLTrivialCb mStopCb; -}; - -#endif /*HSQML_ENGINE_H*/ diff --git a/cbits/HsQMLIntrinsics.cpp b/cbits/HsQMLIntrinsics.cpp deleted file mode 100644 --- a/cbits/HsQMLIntrinsics.cpp +++ /dev/null @@ -1,77 +0,0 @@ -#include -#include - -#include -#include - -#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(string->data()); -} - -extern "C" int hsqml_unmarshal_string( - HsQMLStringHandle* hndl, UTF16** bufPtr) -{ - QString* string = (QString*)hndl; - *bufPtr = reinterpret_cast(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(malloc(bufLen)); - memcpy(buf, cstr.data(), bufLen); - *bufPtr = buf; - return bufLen; -} diff --git a/cbits/HsQMLManager.cpp b/cbits/HsQMLManager.cpp deleted file mode 100644 --- a/cbits/HsQMLManager.cpp +++ /dev/null @@ -1,325 +0,0 @@ -#include -#include -#include -#include -#include -#include -#ifdef Q_WS_MAC -#include -#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; ilog(QString().sprintf("%s = %d.", - cCounterNames[i], gManager->updateCounter( - static_cast(i), 0))); - } - } -} - -QAtomicPointer 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"); - - 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(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); -} diff --git a/cbits/HsQMLManager.h b/cbits/HsQMLManager.h deleted file mode 100644 --- a/cbits/HsQMLManager.h +++ /dev/null @@ -1,109 +0,0 @@ -#ifndef HSQML_MANAGER_H -#define HSQML_MANAGER_H - -#include -#include -#include -#include -#include - -#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::User+StartedLoopEventIndex); - static const QEvent::Type StopLoopEvent = - static_cast(QEvent::User+StopLoopEventIndex); - static const QEvent::Type PendingJobsEvent = - static_cast(QEvent::User+PendingJobsEventIndex); - static const QEvent::Type RemoveGCLockEvent = - static_cast(QEvent::User+RemoveGCLockEventIndex); - -private: - Q_DISABLE_COPY(HsQMLManagerApp) - - int mArgC; - char mArg0; - char* mArgV; - QApplication mApp; -}; - -extern QAtomicPointer gManager; - -#endif /*HSQML_MANAGER_H*/ diff --git a/cbits/HsQMLObject.cpp b/cbits/HsQMLObject.cpp deleted file mode 100644 --- a/cbits/HsQMLObject.cpp +++ /dev/null @@ -1,329 +0,0 @@ -#include -#include -#include - -#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(const_cast(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); - } -} diff --git a/cbits/HsQMLObject.h b/cbits/HsQMLObject.h deleted file mode 100644 --- a/cbits/HsQMLObject.h +++ /dev/null @@ -1,71 +0,0 @@ -#ifndef HSQML_OBJECT_H -#define HSQML_OBJECT_H - -#include -#include -#include -#include - -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*/ diff --git a/cbits/HsQMLWindow.cpp b/cbits/HsQMLWindow.cpp deleted file mode 100644 --- a/cbits/HsQMLWindow.cpp +++ /dev/null @@ -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(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(); -} diff --git a/cbits/HsQMLWindow.h b/cbits/HsQMLWindow.h deleted file mode 100644 --- a/cbits/HsQMLWindow.h +++ /dev/null @@ -1,45 +0,0 @@ -#ifndef HSQML_WINDOW_H -#define HSQML_WINDOW_H - -#include -#include -#include -#include -#include -#include - -#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*/ diff --git a/cbits/Intrinsics.cpp b/cbits/Intrinsics.cpp new file mode 100644 --- /dev/null +++ b/cbits/Intrinsics.cpp @@ -0,0 +1,169 @@ +#include +#include +#include + +#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(hndl); + string->~QString(); +} + +extern "C" UTF16* hsqml_write_string( + int bufLen, HsQMLStringHandle* hndl) +{ + QString* string = reinterpret_cast(hndl); + string->resize(bufLen); + return reinterpret_cast(string->data()); +} + +extern "C" int hsqml_read_string( + HsQMLStringHandle* hndl, UTF16** bufPtr) +{ + QString* string = reinterpret_cast(hndl); + *bufPtr = reinterpret_cast(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(); +} + +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(hndl); + QJSValue* srcValue = reinterpret_cast(srch); + *dstValue = *srcValue; +} + +extern "C" void hsqml_deinit_jval(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(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(hndl); + return value->isBool(); +} + +extern "C" int hsqml_get_jval_bool(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(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(hndl); + return value->isNumber(); +} + +extern "C" int hsqml_get_jval_int(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->toInt(); +} + +extern "C" double hsqml_get_jval_double(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->toNumber(); +} + +extern "C" void hsqml_init_jval_string( + HsQMLJValHandle* hndl, HsQMLStringHandle* strh) +{ + QString* string = reinterpret_cast(strh); + new((void*)hndl) QJSValue(*string); +} +extern "C" int hsqml_is_jval_string(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->isString(); +} + +extern "C" void hsqml_get_jval_string( + HsQMLJValHandle* hndl, HsQMLStringHandle* strh) +{ + QJSValue* value = reinterpret_cast(hndl); + QString* string = reinterpret_cast(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(hndl); + return value->isArray(); +} + +extern "C" unsigned int hsqml_get_jval_array_length(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->property("length").toUInt(); +} + +extern "C" void hsqml_jval_array_get( + HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl) +{ + QJSValue* array = reinterpret_cast(ahndl); + QJSValue* value = reinterpret_cast(hndl); + *value = array->property(i); +} + +extern "C" void hsqml_jval_array_set( + HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl) +{ + QJSValue* array = reinterpret_cast(ahndl); + QJSValue* value = reinterpret_cast(hndl); + array->setProperty(i, *value); +} diff --git a/cbits/Manager.cpp b/cbits/Manager.cpp new file mode 100644 --- /dev/null +++ b/cbits/Manager.cpp @@ -0,0 +1,325 @@ +#include +#include +#include +#include +#include +#include +#ifdef Q_OS_MAC +#include +#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; ilog(QString().sprintf("%s = %d.", + cCounterNames[i], gManager->updateCounter( + static_cast(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"); + + 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(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); +} diff --git a/cbits/Manager.h b/cbits/Manager.h new file mode 100644 --- /dev/null +++ b/cbits/Manager.h @@ -0,0 +1,123 @@ +#ifndef HSQML_MANAGER_H +#define HSQML_MANAGER_H + +#include +#include +#include +#include +#include + +#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::User+StartedLoopEventIndex); + static const QEvent::Type StopLoopEvent = + static_cast(QEvent::User+StopLoopEventIndex); + static const QEvent::Type PendingJobsEvent = + static_cast(QEvent::User+PendingJobsEventIndex); + static const QEvent::Type RemoveGCLockEvent = + static_cast(QEvent::User+RemoveGCLockEventIndex); + +private: + Q_DISABLE_COPY(HsQMLManagerApp) + + int mArgC; + char mArg0; + char* mArgV; + QApplication mApp; +}; + +class ManagerPointer : public QAtomicPointer +{ +public: + HsQMLManager* operator->() const + { + return load(); + } + + operator HsQMLManager*() const + { + return load(); + } +}; + +extern ManagerPointer gManager; + +#endif /*HSQML_MANAGER_H*/ diff --git a/cbits/Object.cpp b/cbits/Object.cpp new file mode 100644 --- /dev/null +++ b/cbits/Object.cpp @@ -0,0 +1,348 @@ +#include +#include +#include + +#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(const_cast(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(hndl); + return (void*)proxy->object(gManager->activeEngine()); +} + +extern HsQMLJValHandle* hsqml_object_get_jval( + HsQMLObjectHandle* hndl) +{ + HsQMLObjectProxy* proxy = reinterpret_cast(hndl); + HsQMLObject* obj = proxy->object(gManager->activeEngine()); + return reinterpret_cast(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(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); + } +} diff --git a/cbits/Object.h b/cbits/Object.h new file mode 100644 --- /dev/null +++ b/cbits/Object.h @@ -0,0 +1,72 @@ +#ifndef HSQML_OBJECT_H +#define HSQML_OBJECT_H + +#include +#include +#include +#include + +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*/ diff --git a/cbits/hsqml.h b/cbits/hsqml.h --- a/cbits/hsqml.h +++ b/cbits/hsqml.h @@ -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); diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -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 diff --git a/src/Graphics/QML.hs b/src/Graphics/QML.hs --- a/src/Graphics/QML.hs +++ b/src/Graphics/QML.hs @@ -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, diff --git a/src/Graphics/QML/Engine.hs b/src/Graphics/QML/Engine.hs --- a/src/Graphics/QML/Engine.hs +++ b/src/Graphics/QML/Engine.hs @@ -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 diff --git a/src/Graphics/QML/Internal/BindCore.chs b/src/Graphics/QML/Internal/BindCore.chs --- a/src/Graphics/QML/Internal/BindCore.chs +++ b/src/Graphics/QML/Internal/BindCore.chs @@ -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'} -> `()' #} diff --git a/src/Graphics/QML/Internal/BindObj.chs b/src/Graphics/QML/Internal/BindObj.chs --- a/src/Graphics/QML/Internal/BindObj.chs +++ b/src/Graphics/QML/Internal/BindObj.chs @@ -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 ^ diff --git a/src/Graphics/QML/Internal/BindPrim.chs b/src/Graphics/QML/Internal/BindPrim.chs --- a/src/Graphics/QML/Internal/BindPrim.chs +++ b/src/Graphics/QML/Internal/BindPrim.chs @@ -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'} -> + `()' #} diff --git a/src/Graphics/QML/Internal/Marshal.hs b/src/Graphics/QML/Internal/Marshal.hs --- a/src/Graphics/QML/Internal/Marshal.hs +++ b/src/Graphics/QML/Internal/Marshal.hs @@ -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} diff --git a/src/Graphics/QML/Internal/MetaObj.hs b/src/Graphics/QML/Internal/MetaObj.hs --- a/src/Graphics/QML/Internal/MetaObj.hs +++ b/src/Graphics/QML/Internal/MetaObj.hs @@ -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 diff --git a/src/Graphics/QML/Internal/Objects.hs b/src/Graphics/QML/Internal/Objects.hs deleted file mode 100644 --- a/src/Graphics/QML/Internal/Objects.hs +++ /dev/null @@ -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 - diff --git a/src/Graphics/QML/Internal/Types.hs b/src/Graphics/QML/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Internal/Types.hs @@ -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 +} diff --git a/src/Graphics/QML/Marshal.hs b/src/Graphics/QML/Marshal.hs --- a/src/Graphics/QML/Marshal.hs +++ b/src/Graphics/QML/Marshal.hs @@ -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) diff --git a/src/Graphics/QML/Objects.hs b/src/Graphics/QML/Objects.hs --- a/src/Graphics/QML/Objects.hs +++ b/src/Graphics/QML/Objects.hs @@ -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 diff --git a/test/Graphics/QML/Test/DataTest.hs b/test/Graphics/QML/Test/DataTest.hs new file mode 100644 --- /dev/null +++ b/test/Graphics/QML/Test/DataTest.hs @@ -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 ())] diff --git a/test/Graphics/QML/Test/Framework.hs b/test/Graphics/QML/Test/Framework.hs --- a/test/Graphics/QML/Test/Framework.hs +++ b/test/Graphics/QML/Test/Framework.hs @@ -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 diff --git a/test/Graphics/QML/Test/GenURI.hs b/test/Graphics/QML/Test/GenURI.hs deleted file mode 100644 --- a/test/Graphics/QML/Test/GenURI.hs +++ /dev/null @@ -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 "" "" diff --git a/test/Graphics/QML/Test/Harness.hs b/test/Graphics/QML/Test/Harness.hs --- a/test/Graphics/QML/Test/Harness.hs +++ b/test/Graphics/QML/Test/Harness.hs @@ -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 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 diff --git a/test/Graphics/QML/Test/ScriptDSL.hs b/test/Graphics/QML/Test/ScriptDSL.hs --- a/test/Graphics/QML/Test/ScriptDSL.hs +++ b/test/Graphics/QML/Test/ScriptDSL.hs @@ -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 diff --git a/test/Graphics/QML/Test/SignalTest.hs b/test/Graphics/QML/Test/SignalTest.hs --- a/test/Graphics/QML/Test/SignalTest.hs +++ b/test/Graphics/QML/Test/SignalTest.hs @@ -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] diff --git a/test/Graphics/QML/Test/SimpleTest.hs b/test/Graphics/QML/Test/SimpleTest.hs --- a/test/Graphics/QML/Test/SimpleTest.hs +++ b/test/Graphics/QML/Test/SimpleTest.hs @@ -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 diff --git a/test/Test1.hs b/test/Test1.hs --- a/test/Test1.hs +++ b/test/Test1.hs @@ -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