packages feed

hsqml 0.3.0.0 → 0.3.1.0

raw patch · 14 files changed

+496/−41 lines, 14 filesdep ~transformers

Dependency ranges changed: transformers

Files

CHANGELOG view
@@ -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
+ README view
@@ -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/
+ SetupNoTH.hs view
@@ -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'
cbits/Intrinsics.cpp view
@@ -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)
cbits/Manager.cpp view
@@ -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>("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<void*>(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<HsQMLObject*>(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<void*>(p);+    if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) {+        if (HsQMLObject* obj = dynamic_cast<HsQMLObject*>(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>("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;}
cbits/Manager.h view
@@ -5,6 +5,7 @@ #include <QtCore/QAtomicInt> #include <QtCore/QMutex> #include <QtCore/QString>+#include <QtCore/QVariant> #include <QtWidgets/QApplication>  #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;
cbits/Object.cpp view
@@ -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(
cbits/Object.h view
@@ -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);
cbits/hsqml.h view
@@ -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(
hsqml.cabal view
@@ -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
src/Graphics/QML/Internal/BindObj.chs view
@@ -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'} ->
src/Graphics/QML/Internal/MetaObj.hs view
@@ -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
src/Graphics/QML/Objects.hs view
@@ -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.
test/Graphics/QML/Test/SimpleTest.hs view
@@ -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