diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,15 @@ HsQML - Release History +release-0.3.1.0 - 2014.06.11 + + * Added properties with constant annotation. + * Added runtime warning for users of the non-threaded RTS. + * Added non-TH version of Setup.hs. + * Relaxed Cabal dependency constraint on 'transformers'. + * Fixed premature garbage collection of QML objects. + * Fixed intermittent crash on exit when firing signals. + * Fixed crash when using Cmd-Q to exit on MacOS. + release-0.3.0.0 - 2014.05.04 * Ported to Qt 5 and Qt Quick 2 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +HsQML +===== + +HsQML is a Haskell binding to Qt Quick, a cross-platform framework for creating +graphical user interfaces. For further information on installing and using it, +please see the project's web site. + +Home Page: http://www.gekkou.co.uk/software/hsqml/ +Darcs Repository: http://hub.darcs.net/komadori/HsQML +Issue Tracker: http://trac.gekkou.co.uk/hsqml/ diff --git a/SetupNoTH.hs b/SetupNoTH.hs new file mode 100644 --- /dev/null +++ b/SetupNoTH.hs @@ -0,0 +1,280 @@ +#!/usr/bin/runhaskell +-- This is an alternate version of Setup.hs which doesn't use Template Haskell. +module Main where + +import Control.Monad +import Data.Char +import Data.List +import Data.Maybe +import Distribution.Simple +import Distribution.Simple.BuildPaths +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.Program +import Distribution.Simple.Program.Ld +import Distribution.Simple.Register +import Distribution.Simple.Setup +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import qualified Distribution.InstalledPackageInfo as I +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription +import System.FilePath + +-- 'LocalBuildInfo' record changed fields in Cabal 1.18 +extractCLBI :: LocalBuildInfo -> ComponentLocalBuildInfo +extractCLBI x = getComponentLocalBuildInfo x CLibName +-- 'programFindLocation' field changed signature in Cabal 1.18 +adaptFindLoc :: (Verbosity -> a) -> Verbosity -> ProgramSearchPath -> a +adaptFindLoc f x _ = f x +-- 'rawSystemStdInOut' function changed signature in Cabal 1.18 +rawSystemStdErr v p a = rawSystemStdInOut v p a Nothing Nothing Nothing False +-- 'programPostConf' field changed signature in Cabal 1.18 +noPostConf _ c = return c + +main :: IO () +main = defaultMainWithHooks simpleUserHooks { + confHook = confWithQt, buildHook = buildWithQt, + 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 . simpleParse $ getCustomStr name pkgDesc + +confWithQt :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> + IO LocalBuildInfo +confWithQt (gpd,hbi) flags = do + let verb = fromFlag $ configVerbosity flags + mocPath <- findProgramLocation verb "moc" + cppPath <- findProgramLocation verb "cpp" + 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 + mocProgram qtVersionRange (withPrograms lbi) + -- Force enable GHCi workaround library if flag set and not using shared libs + let forceGHCiLib = + (getCustomFlag "x-force-ghci-lib" $ localPkgDescr lbi) && + (not $ withSharedLib lbi) + -- Update LocalBuildInfo + 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 + where updateChildren (cond,left,right) = + (cond, mapCondTree f left, fmap (mapCondTree f) right) + +substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo +substPaths mocPath cppPath build = + let toRoot = takeDirectory . takeDirectory . fromMaybe "" + 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 () +buildWithQt pkgDesc lbi hooks flags = do + let verb = fromFlag $ buildVerbosity flags + libs' <- maybeMapM (\lib -> fmap (\lib' -> + lib {libBuildInfo = lib'}) $ fixQtBuild verb lbi $ libBuildInfo lib) $ + library pkgDesc + let pkgDesc' = pkgDesc {library = libs'} + lbi' = if (needsGHCiFix pkgDesc lbi) + then lbi {withGHCiLib = False, splitObjs = False} else lbi + buildHook simpleUserHooks pkgDesc' lbi' hooks flags + case libs' of + Just lib -> when (needsGHCiFix pkgDesc lbi) $ + buildGHCiFix verb pkgDesc lbi lib + Nothing -> return () + +fixQtBuild :: Verbosity -> LocalBuildInfo -> BuildInfo -> IO BuildInfo +fixQtBuild verb lbi build = do + let moc = fromJust $ lookupProgram mocProgram $ withPrograms lbi + incs = words $ fromMaybe "" $ lookup "x-moc-headers" $ + customFieldsBI build + bDir = buildDir lbi + cpps = map (\inc -> + bDir (takeDirectory inc) + ("moc_" ++ (takeBaseName inc) ++ ".cpp")) incs + mapM_ (\(i,o) -> do + createDirectoryIfMissingVerbose verb True (takeDirectory o) + runProgram verb moc [i,"-o",o]) $ zip incs cpps + return build {cSources = cpps ++ cSources build, + ccOptions = "-fPIC" : ccOptions build} + +needsGHCiFix :: PackageDescription -> LocalBuildInfo -> Bool +needsGHCiFix pkgDesc lbi = + withGHCiLib lbi && getCustomFlag "x-separate-cbits" pkgDesc + +mkGHCiFixLibPkgId :: PackageDescription -> PackageIdentifier +mkGHCiFixLibPkgId pkgDesc = + let pid = packageId pkgDesc + (PackageName name) = pkgName pid + in pid {pkgName = PackageName $ "cbits-" ++ name} + +mkGHCiFixLibName :: PackageDescription -> String +mkGHCiFixLibName pkgDesc = + ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension + +mkGHCiFixLibRefName :: PackageDescription -> String +mkGHCiFixLibRefName pkgDesc = + prefix ++ display (mkGHCiFixLibPkgId pkgDesc) + where prefix = if dllExtension == "dll" then "lib" else "" + +buildGHCiFix :: + Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> IO () +buildGHCiFix verb pkgDesc lbi lib = do + let bDir = buildDir lbi + ms = map ModuleName.toFilePath $ libModules lib + hsObjs = map ((bDir ) . (<.> "o")) ms + stubObjs <- fmap catMaybes $ + mapM (findFileWithExtension ["o"] [bDir]) $ map (++ "_stub") ms + (ld,_) <- requireProgram verb ldProgram (withPrograms lbi) + combineObjectFiles verb ld + (bDir (("HS" ++) $ display $ packageId pkgDesc) <.> "o") + (stubObjs ++ hsObjs) + (ghc,_) <- requireProgram verb ghcProgram (withPrograms lbi) + let bi = libBuildInfo lib + runProgram verb ghc ( + ["-shared","-o",bDir (mkGHCiFixLibName pkgDesc)] ++ + (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) ++ + (map ("-L" ++) $ extraLibDirs bi) ++ + (map ((bDir ) . flip replaceExtension objExtension) $ cSources bi)) + return () + +mocProgram :: Program +mocProgram = Program { + programName = "moc", + programFindLocation = adaptFindLoc $ + \verb -> findProgramLocation verb "moc", + programFindVersion = \verb path -> do + (oLine,eLine,_) <- rawSystemStdErr verb path ["-v"] + return $ + (findSubseq (stripPrefix "(Qt ") eLine `mplus` + findSubseq (stripPrefix "moc ") oLine) >>= + simpleParse . takeWhile (\c -> isDigit c || c == '.'), + programPostConf = noPostConf +} + +qtVersionRange :: VersionRange +qtVersionRange = intersectVersionRanges + (orLaterVersion $ Version [5,0] []) (earlierVersion $ Version [6,0] []) + +copyWithQt :: + PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () +copyWithQt pkgDesc lbi hooks flags = do + copyHook simpleUserHooks pkgDesc lbi hooks flags + let verb = fromFlag $ copyVerbosity flags + dest = fromFlag $ copyDest flags + bDir = buildDir lbi + libDir = libdir $ absoluteInstallDirs pkgDesc lbi dest + file = mkGHCiFixLibName pkgDesc + when (needsGHCiFix pkgDesc lbi) $ + installOrdinaryFile verb (bDir file) (libDir file) + +regWithQt :: + PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () +regWithQt pkg@PackageDescription { library = Just lib } lbi _ flags = do + let verb = fromFlag $ regVerbosity flags + inplace = fromFlag $ regInPlace flags + dist = fromFlag $ regDistPref flags + pkgDb = withPackageDB lbi + clbi = extractCLBI lbi + instPkgInfo <- generateRegistrationInfo + verb pkg lib lbi clbi inplace dist + 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) $ + I.showInstalledPackageInfo instPkgInfo' + _ | fromFlag (regGenScript flags) -> + die "Registration scripts are not implemented." + | otherwise -> + registerPackage verb instPkgInfo' pkg lbi inplace pkgDb +regWithQt pkgDesc _ _ flags = + setupMessage (fromFlag $ regVerbosity flags) + "Package contains no library to register:" (packageId pkgDesc) + +instWithQt :: + PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () +instWithQt pkgDesc lbi hooks flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyVerbosity = installVerbosity flags + } + regFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + 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/Intrinsics.cpp b/cbits/Intrinsics.cpp --- a/cbits/Intrinsics.cpp +++ b/cbits/Intrinsics.cpp @@ -136,8 +136,9 @@ /* Array */ extern "C" void hsqml_init_jval_array(HsQMLJValHandle* hndl, unsigned int len) { - new((void*)hndl) QJSValue( - gManager->activeEngine()->declEngine()->newArray(len)); + HsQMLEngine* engine = gManager->activeEngine(); + Q_ASSERT(engine); + new((void*)hndl) QJSValue(engine->declEngine()->newArray(len)); } extern "C" int hsqml_is_jval_array(HsQMLJValHandle* hndl) diff --git a/cbits/Manager.cpp b/cbits/Manager.cpp --- a/cbits/Manager.cpp +++ b/cbits/Manager.cpp @@ -11,10 +11,18 @@ #include "Manager.h" #include "Object.h" +// Declarations for part of Qt's internal API +Q_DECL_IMPORT const QVariant::Handler* qcoreVariantHandler(); +namespace QVariantPrivate { +Q_DECL_IMPORT void registerHandler( + const int name, const QVariant::Handler *handler); +} + static const char* cCounterNames[] = { "ClassCounter", "ObjectCounter", "QObjectCounter", + "VariantCounter", "ClassSerial", "ObjectSerial" }; @@ -31,6 +39,16 @@ } } +static void hooked_construct(QVariant::Private* p, const void* copy) +{ + gManager->hookedConstruct(p, copy); +} + +static void hooked_clear(QVariant::Private* p) +{ + gManager->hookedClear(p); +} + ManagerPointer gManager; HsQMLManager::HsQMLManager( @@ -40,21 +58,27 @@ , mAtExit(false) , mFreeFun(freeFun) , mFreeStable(freeStable) + , mOriginalHandler(qcoreVariantHandler()) + , mHookedHandler(*mOriginalHandler) , mApp(NULL) , mLock(QMutex::Recursive) , mRunning(false) , mRunCount(0) + , mStackBase(NULL) , mStartCb(NULL) , mJobsCb(NULL) , mYieldCb(NULL) , mActiveEngine(NULL) { - qRegisterMetaType("HsQMLEngineConfig"); - + // Get log level from environment const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL"); if (env) { setLogLevel(QString(env).toInt()); } + + // Set hooked handler functions + mHookedHandler.construct = &hooked_construct; + mHookedHandler.clear = &hooked_clear; } void HsQMLManager::setLogLevel(int ll) @@ -95,6 +119,43 @@ mFreeStable(stablePtr); } +void HsQMLManager::hookedConstruct(QVariant::Private* p, const void* copy) +{ + char guard; + mOriginalHandler->construct(p, copy); + void* pp = reinterpret_cast(p); + // The QVariant internals sometimes use a special code path for pointer + // values which avoids calling the handler functions. This makes it + // difficult to use them to keep a reference count. However, it's my + // observation that this only affects transient QVariants created on the + // stack inside the JavaScript engine's marshalling code. The persistent + // QVariants stored in the heap are manipulated using a more restricted set + // of operations which always use the handler functions. Hence, by assuming + // that the stack can be discounted, it's possible to keep an accurate + // count of heap references using these hooks. + if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) { + if (HsQMLObject* obj = dynamic_cast(p->data.o)) { + HsQMLObjectProxy* proxy = obj->proxy(); + proxy->ref(HsQMLObjectProxy::Variant); + proxy->tryGCLock(); + updateCounter(VariantCount, 1); + } + } +} + +void HsQMLManager::hookedClear(QVariant::Private* p) +{ + char guard; + void* pp = reinterpret_cast(p); + if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) { + if (HsQMLObject* obj = dynamic_cast(p->data.o)) { + obj->proxy()->deref(HsQMLObjectProxy::Variant); + updateCounter(VariantCount, -1); + } + } + mOriginalHandler->clear(p); +} + bool HsQMLManager::isEventThread() { return mApp && mApp->thread() == QThread::currentThread(); @@ -125,12 +186,26 @@ } #endif - // Create application object + // Check for non-threaded RTS + if (yieldCb) { + HSQML_LOG(0, + "Warning: CPU cannot idle when using the non-threaded RTS."); + } + + // Perform one-time initialisation if (!mApp) { + // Install hooked handler for QVariants + QVariantPrivate::registerHandler(0, &mHookedHandler); + + // Register custom type + qRegisterMetaType("HsQMLEngineConfig"); + + // Create application object mApp = new HsQMLManagerApp(); } - // Save callbacks + // Save stack base and callbacks + mStackBase = &locker; mStartCb = startCb; mJobsCb = jobsCb; mYieldCb = yieldCb; @@ -145,8 +220,20 @@ } // Run loop - int ret = mApp->exec(); + int ret; + do { + ret = mApp->exec(); + // Kill all engines + const QObjectList& cs = gManager->mApp->children(); + while (!cs.empty()) { + delete cs.front(); + } + + // Cmd-Q on MacOS can kill the event loop before we're ready + // Keep it running until a StopLoopEvent is received + } while (ret == 0 && mRunning); + // Remove redundant events QCoreApplication::removePostedEvents( mApp, HsQMLManagerApp::RemoveGCLockEvent); @@ -250,10 +337,6 @@ 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;} diff --git a/cbits/Manager.h b/cbits/Manager.h --- a/cbits/Manager.h +++ b/cbits/Manager.h @@ -5,6 +5,7 @@ #include #include #include +#include #include #include "hsqml.h" @@ -22,6 +23,7 @@ ClassCount, ObjectCount, QObjectCount, + VariantCount, ClassSerial, ObjectSerial, TotalCounters @@ -36,6 +38,8 @@ int updateCounter(CounterId, int); void freeFun(HsFunPtr); void freeStable(HsStablePtr); + void hookedConstruct(QVariant::Private*, const void*); + void hookedClear(QVariant::Private*); bool isEventThread(); typedef HsQMLEventLoopStatus EventLoopStatus; EventLoopStatus runEventLoop( @@ -57,10 +61,13 @@ bool mAtExit; void (*mFreeFun)(HsFunPtr); void (*mFreeStable)(HsStablePtr); + const QVariant::Handler* mOriginalHandler; + QVariant::Handler mHookedHandler; HsQMLManagerApp* mApp; QMutex mLock; bool mRunning; int mRunCount; + void* mStackBase; HsQMLTrivialCb mStartCb; HsQMLTrivialCb mJobsCb; HsQMLTrivialCb mYieldCb; diff --git a/cbits/Object.cpp b/cbits/Object.cpp --- a/cbits/Object.cpp +++ b/cbits/Object.cpp @@ -6,7 +6,7 @@ #include "Class.h" #include "Manager.h" -static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event"}; +static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event", "Var"}; HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass) : mHaskell(haskell) @@ -55,11 +55,11 @@ { Q_ASSERT(gManager->isEventThread()); - mObject = NULL; - HSQML_LOG(5, QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.", mKlass->name(), mSerial, mObject)); + + mObject = NULL; } void HsQMLObjectProxy::tryGCLock() @@ -105,7 +105,7 @@ count ? "Ref" : "New", mKlass->name(), mSerial, cRefSrcNames[src], count+1)); - if (src == Handle) { + if (src == Handle || src == Variant) { mHndlCount.fetchAndAddOrdered(1); } } @@ -113,12 +113,18 @@ void HsQMLObjectProxy::deref(RefSrc src) { // Remove JavaScript GC lock when there are no handles - if (src == Handle) { + if (src == Handle || src == Variant) { 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)); + if (src == Handle) { + // Handles can be dereferenced from any thread. The event will + // remove the lock if there are still no handles by the time + // it reaches the event loop. + gManager->postObjectEvent(new HsQMLObjectEvent(this)); + } + else { + removeGCLock(); + } } } @@ -258,16 +264,25 @@ return (HsQMLObjectHandle*)proxy; } -extern "C" void hsqml_object_set_active( +extern "C" int hsqml_object_set_active( HsQMLObjectHandle* hndl) { HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl; if (proxy) { - gManager->setActiveEngine(proxy->engine()); + HsQMLEngine* engine = proxy->engine(); + if (engine) { + gManager->setActiveEngine(engine); + } + else { + // Nothing can be done if the object hasn't been marshalled before + // because otherwise the relevant engine is unknown. + return false; + } } else { gManager->setActiveEngine(NULL); } + return true; } extern "C" HsStablePtr hsqml_object_get_hs_typerep( diff --git a/cbits/Object.h b/cbits/Object.h --- a/cbits/Object.h +++ b/cbits/Object.h @@ -22,7 +22,7 @@ void tryGCLock(); void removeGCLock(); HsQMLEngine* engine() const; - enum RefSrc {Handle, Object, Event}; + enum RefSrc {Handle, Object, Event, Variant}; void ref(RefSrc); void deref(RefSrc); diff --git a/cbits/hsqml.h b/cbits/hsqml.h --- a/cbits/hsqml.h +++ b/cbits/hsqml.h @@ -141,7 +141,7 @@ extern HsQMLObjectHandle* hsqml_create_object( HsStablePtr, HsQMLClassHandle*); -extern void hsqml_object_set_active( +extern int hsqml_object_set_active( HsQMLObjectHandle*); extern HsStablePtr hsqml_object_get_hs_typerep( diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -1,5 +1,5 @@ Name: hsqml -Version: 0.3.0.0 +Version: 0.3.1.0 Cabal-version: >= 1.14 Build-type: Custom License: BSD3 @@ -9,9 +9,12 @@ Maintainer: komadori@gekkou.co.uk Stability: experimental Homepage: http://www.gekkou.co.uk/software/hsqml/ +Bug-reports: http://trac.gekkou.co.uk/hsqml/ Category: Graphics Synopsis: Haskell binding for Qt Quick -Extra-source-files: CHANGELOG cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs +Extra-source-files: + README CHANGELOG SetupNoTH.hs + cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs Description: A Haskell binding for Qt Quick. @@ -40,7 +43,7 @@ filepath == 1.3.*, text >= 0.11 && < 1.2, tagged >= 0.4 && < 0.8, - transformers >= 0.2 && < 0.4 + transformers >= 0.2 && < 0.5 Exposed-modules: Graphics.QML Graphics.QML.Debug 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 @@ -7,8 +7,10 @@ import Graphics.QML.Internal.Types {#import Graphics.QML.Internal.BindPrim #} -import Control.Exception (bracket_) +import Control.Exception (bracket) +import Control.Monad (void) import Foreign.C.Types +import Foreign.Marshal.Utils (toBool) import Foreign.Ptr import Foreign.ForeignPtr.Safe import Foreign.ForeignPtr.Unsafe @@ -81,14 +83,14 @@ {#fun unsafe hsqml_object_set_active as ^ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle'} -> - `()' #} + `Bool' toBool #} withActiveObject :: HsQMLObjectHandle -> IO () -> IO () withActiveObject hndl action = - bracket_ + bracket (hsqmlObjectSetActive $ Just hndl) - (hsqmlObjectSetActive Nothing) - action + (\ok -> if ok then void $ hsqmlObjectSetActive Nothing else return ()) + (\ok -> if ok then action else return ()) {#fun unsafe hsqml_object_get_hs_typerep as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} -> 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 @@ -61,9 +61,10 @@ data MemberKind = MethodMember + | ConstPropertyMember | PropertyMember | SignalMember - deriving (Bounded, Enum, Eq) + deriving Eq -- | Represents a named member of the QML class which wraps type @tt@. data Member tt = Member { @@ -111,12 +112,14 @@ 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 + let mms = filterMembers SignalMember ms ++ + filterMembers MethodMember ms + mapM_ writeMethodParams mms + mapM_ writeMethod mms + let pms = filterMembers ConstPropertyMember ms ++ + filterMembers PropertyMember ms + mapM_ writeProperty pms + mapM_ writePropertySig pms writeInt 0 in enc @@ -204,6 +207,7 @@ writeString $ memberName p writeInt $ typeId $ memberType p writeInt (pfReadable .|. pfScriptable .|. + (if (ConstPropertyMember == memberKind p) then pfConstant else 0) .|. (if (isJust $ memberFunAux p) then pfWritable else 0) .|. (if (isJust $ memberKey p) then pfNotify else 0)) state <- get 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 @@ -42,10 +42,12 @@ SignalSuffix, -- * Properties + defPropertyConst, defPropertyRO, defPropertySigRO, defPropertyRW, defPropertySigRW, + defPropertyConst', defPropertyRO', defPropertySigRO', defPropertyRW', @@ -379,7 +381,7 @@ -- | 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'. +-- or ii) value-based using a 'SignalKey' value creating using 'newSignalKey'. defSignal :: forall obj skv. (SignalKeyValue skv) => String -> skv -> Member obj defSignal name key = @@ -393,7 +395,17 @@ Nothing (Just $ signalKey key) --- | Fires a signal on an 'Object', specified using a 'SignalKeyValue'. +-- | Fires a signal defined on an object instance. The signal is identified +-- using either a type- or value-based signal key, as described in the +-- documentation for 'defSignal'. The first argument is the signal key, the +-- second is the object, and the remaining arguments, if any, are the arguments +-- to the signal as specified by the signal key. +-- +-- If this function is called using a signal key which doesn't match a signal +-- defined on the supplied object, it will silently do nothing. +-- +-- This function is safe to call from any thread. Any attached signal handlers +-- will be executed asynchronously on the event loop thread. fireSignal :: forall tt skv. (Marshal tt, CanPassTo tt ~ Yes, IsObjType tt ~ Yes, SignalKeyValue skv) => skv -> tt -> SignalValueParams skv @@ -467,6 +479,20 @@ -- Property -- +-- | Defines a named constant property using an accessor function in the IO +-- monad. +defPropertyConst :: forall tt tr. + (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr, + CanReturnTo tr ~ Yes) => String -> + (tt -> IO tr) -> Member (GetObjType tt) +defPropertyConst name g = Member ConstPropertyMember + name + (untag (mTypeCVal :: Tagged tr TypeId)) + [] + (mkUniformFunc g) + Nothing + Nothing + -- | Defines a named read-only property using an accessor function in the IO -- monad. defPropertyRO :: forall tt tr. @@ -521,6 +547,13 @@ (mkUniformFunc g) (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b)) (Just $ signalKey key) + +-- | Alias of 'defPropertyConst' which is less polymorphic to reduce the need +-- for type signatures. +defPropertyConst' :: forall obj tr. + (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) => + String -> (ObjRef obj -> IO tr) -> Member obj +defPropertyConst' = defPropertyConst -- | Alias of 'defPropertyRO' which is less polymorphic to reduce the need for -- type signatures. 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 @@ -111,7 +111,8 @@ _ -> return $ Left TBadActionCtor] data SimpleProperties - = SPGetIntRO Int32 + = SPGetIntConst Int32 + | SPGetIntRO Int32 | SPGetInt Int32 | SPSetInt Int32 | SPGetDouble Double @@ -126,6 +127,7 @@ legalActionIn (SPSetObject n) env = testEnvIsaJ n testObjectType env legalActionIn _ _ = True nextActionsFor env = mayOneof [ + SPGetIntConst <$> fromGen arbitrary, SPGetIntRO <$> fromGen arbitrary, SPGetInt <$> fromGen arbitrary, SPSetInt <$> fromGen arbitrary, @@ -138,6 +140,7 @@ updateEnvRaw (SPGetObject n) = testEnvStep . testEnvSerial (\s -> testEnvSetJ n testObjectType s) updateEnvRaw _ = testEnvStep + actionRemote (SPGetIntConst v) n = testProp n "propIntConst" $ S.literal v actionRemote (SPGetIntRO v) n = testProp n "propIntRO" $ S.literal v actionRemote (SPGetInt v) n = testProp n "propIntR" $ S.literal v actionRemote (SPSetInt v) n = setProp n "propIntW" $ S.literal v @@ -150,6 +153,10 @@ mockObjDef = [ -- There are seperate properties for testing accessors and mutators -- becasue QML produces spurious reads when writing. + defPropertyRO "propIntConst" + (\m -> expectAction m $ \a -> case a of + SPGetIntConst v -> return $ Right v + _ -> return $ Left TBadActionCtor), defPropertyRO "propIntRO" (\m -> expectAction m $ \a -> case a of SPGetIntRO v -> return $ Right v