hsqml (empty) → 0.1.0

raw patch · 25 files changed

+2533/−0 lines, 25 filesdep +basedep +containersdep +directorybuild-type:Customsetup-changed

Dependencies added: base, containers, directory, filepath, hsqml, network, tagged, text, transformers

Files

LICENSE +30/−0
Setup.hs +224/−0
cbits/HsQMLClass.cpp +113/−0
cbits/HsQMLClass.h +41/−0
cbits/HsQMLEngine.cpp +55/−0
cbits/HsQMLEngine.h +41/−0
cbits/HsQMLIntrinsics.cpp +77/−0
cbits/HsQMLManager.cpp +78/−0
cbits/HsQMLManager.h +42/−0
cbits/HsQMLObject.cpp +199/−0
cbits/HsQMLObject.h +45/−0
cbits/HsQMLWindow.cpp +104/−0
cbits/HsQMLWindow.h +45/−0
cbits/hsqml.h +99/−0
hsqml.cabal +84/−0
src/Graphics/QML.hs +45/−0
src/Graphics/QML/Debug.hs +11/−0
src/Graphics/QML/Engine.hs +111/−0
src/Graphics/QML/Internal/Engine.chs +48/−0
src/Graphics/QML/Internal/Marshal.hs +63/−0
src/Graphics/QML/Internal/Objects.chs +143/−0
src/Graphics/QML/Internal/PrimValues.chs +82/−0
src/Graphics/QML/Marshal.hs +155/−0
src/Graphics/QML/Objects.hs +450/−0
test/Test1.hs +148/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2010-2012, Robin KAY++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Robin KAY nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,224 @@+#!/usr/bin/runhaskell +module Main where++import Data.List+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.PackageIndex+import Distribution.Simple.Setup+import Distribution.Simple.Utils (rawSystemExit)+import qualified Distribution.InstalledPackageInfo as I+import Distribution.PackageDescription+import System.Directory+import System.FilePath++import Control.Monad+import Data.Char+import Data.Maybe+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.BuildPaths+import Distribution.Simple.Program+import Distribution.Simple.Program.Ld+import Distribution.Simple.Register+import Distribution.Simple.Utils+import Distribution.Text+import Distribution.Version+import Distribution.Verbosity+import System.FilePath++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+  confHook = confWithQt, buildHook = buildWithQt,+  copyHook = copyWithQt, instHook = instWithQt,+  regHook = regWithQt}++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 condLib = fromJust $ condLibrary gpd+      fixCondLib lib = lib {+        libBuildInfo = substPaths mocPath cppPath $ libBuildInfo lib} +      condLib' = mapCondTree fixCondLib condLib+      gpd' = gpd {condLibrary = Just $ condLib'}+  lbi <- confHook simpleUserHooks (gpd',hbi) flags+  (_,_,db') <- requireProgramVersion verb+    mocProgram qtVersionRange (withPrograms lbi)+  return $ lbi {withPrograms = db'}++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 = 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++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+    exes' <- mapM (\exe -> fmap (\exe' ->+      exe {buildInfo = exe'}) $ fixQtBuild verb lbi $ buildInfo exe) $+      executables pkgDesc+    let pkgDesc' = pkgDesc {library = libs', executables = exes'}+        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 &&) $ fromMaybe False $ do+    lib <- library pkgDesc+    str <- lookup "x-separate-cbits" $ customFieldsBI $ libBuildInfo lib+    simpleParse str++mkGHCiFixLibPkgId :: PackageDescription -> PackageIdentifier+mkGHCiFixLibPkgId pkgDesc =+  let id = packageId pkgDesc+      (PackageName name) = pkgName id+  in id {pkgName = PackageName $ "cbits-" ++ name}++mkGHCiFixLibName :: PackageDescription -> String+mkGHCiFixLibName pkgDesc =+  ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension++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+      bDir = buildDir lbi+  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 = flip findProgramLocation "moc",+  programFindVersion = \verbosity path -> do+    (_,line,_) <- rawSystemStdInOut verbosity path ["-v"] Nothing False+    return $+      findSubseq (stripPrefix "(Qt ") line >>=+      Just . takeWhile (\c -> isDigit c || c == '.') >>=+      simpleParse,+  programPostConf = \_ _ -> return []+}++qtVersionRange :: VersionRange+qtVersionRange = orLaterVersion $ Version [4,7] []++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@LocalBuildInfo     { libraryConfig = Just clbi } hooks flags = do+  let verb    = fromFlag $ regVerbosity flags+      inplace = fromFlag $ regInPlace flags+      dist    = fromFlag $ regDistPref flags+      pkgDb   = withPackageDB lbi+  instPkgInfo <- generateRegistrationInfo+    verb pkg lib lbi clbi inplace dist+  let instPkgInfo' = if (needsGHCiFix pkg lbi)+        then instPkgInfo {I.extraGHCiLibraries =+          (display $ mkGHCiFixLibPkgId pkg) :+          I.extraGHCiLibraries instPkgInfo}+        else instPkgInfo+  case flagToMaybe $ regGenPkgConf flags of+    Just regFile -> do+      let regFile = fromMaybe (display (packageId pkg) <.> "conf")+            (fromFlag $ regGenPkgConf flags)+      writeUTF8File 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++maybeMapM :: (Monad m) => (a -> m b) -> (Maybe a) -> m (Maybe b)+maybeMapM f = maybe (return Nothing) $ liftM Just . f++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

+ cbits/HsQMLClass.cpp view

@@ -0,0 +1,113 @@+#include <cstdlib>+#include <HsFFI.h>+#include <QAtomicInt>+#include <QMetaObject>+#include <QString>+#include <QDebug>++#include "hsqml.h"+#include "HsQMLClass.h"+#include "HsQMLManager.h"++QAtomicInt gClassId;++HsQMLClass::HsQMLClass(+    unsigned int*  metaData,+    char*          metaStrData,+    HsQMLUniformFunc* methods,+    HsQMLUniformFunc* properties)+    : mRefCount(0)+    , mMetaData(metaData)+    , mMetaStrData(metaStrData)+    , mMethods(methods)+    , mProperties(properties)+    , mMethodCount(metaData[MD_METHOD_COUNT])+    , mPropertyCount(metaData[MD_PROPERTY_COUNT])+    , mMetaObject(QMetaObject {{+          &QObject::staticMetaObject,+          mMetaStrData,+          mMetaData,+          0}})+{+    ref(Handle);+}++HsQMLClass::~HsQMLClass()+{+    for (int i=0; i<mMethodCount; i++) {+        gManager->freeFun((HsFunPtr)mMethods[i]);+    }+    for (unsigned int i=0; i<2*mPropertyCount; i++) {+        if (mProperties[i]) {+            gManager->freeFun((HsFunPtr)mProperties[i]);+        }+    }+    std::free(mMetaData);+    std::free(mMetaStrData);+    std::free(mMethods);+    std::free(mProperties);+}++const char* HsQMLClass::name()+{+    return mMetaObject.className();+} ++const HsQMLUniformFunc* HsQMLClass::methods()+{+    return mMethods;+}++const HsQMLUniformFunc* HsQMLClass::properties()+{+    return mProperties;+}++void HsQMLClass::ref(RefSrc src)+{+    int count = mRefCount.fetchAndAddOrdered(1);++    if (gLogLevel >= (count == 0 ? 1 : 2)) {+        qDebug() << QString().sprintf(+            "HsQML: %s Class, name=%s, src=%d, count=%d.",+            count ? "Ref" : "New", name(), src, count+1);+    }+}++void HsQMLClass::deref(RefSrc src)+{+    int count = mRefCount.fetchAndAddOrdered(-1);++    if (gLogLevel >= (count == 1 ? 1 : 2)) {+        qDebug() << QString().sprintf(+            "HsQML: %s Class, name=%s, src=%d, count=%d.",+            count > 1 ? "Deref" : "Delete", name(), src, count);+    }++    if (count == 1) {+        delete this;+    }+}++extern "C" int hsqml_get_next_class_id()+{+    return gClassId.fetchAndAddRelaxed(1);+}++extern "C" HsQMLClassHandle* hsqml_create_class(+    unsigned int*  metaData,+    char*          metaStrData,+    HsQMLUniformFunc* methods,+    HsQMLUniformFunc* properties)+{+    HsQMLClass* klass = new HsQMLClass(+            metaData, metaStrData, methods, properties);+    return (HsQMLClassHandle*)klass;+}++extern "C" void hsqml_finalise_class_handle(+    HsQMLClassHandle* hndl)+{+    HsQMLClass* klass = (HsQMLClass*)hndl;+    klass->deref(HsQMLClass::Handle);+}

+ cbits/HsQMLClass.h view

@@ -0,0 +1,41 @@+#ifndef HSQML_CLASS_H+#define HSQML_CLASS_H++#include <QObject>+#include <QAtomicInt>++#include "hsqml.h"++enum MDFields {+    MD_CLASS_NAME     = 1,+    MD_METHOD_COUNT   = 4,+    MD_PROPERTY_COUNT = 6,+};++class HsQMLClass+{+public:+    HsQMLClass(+        unsigned int*, char*, HsQMLUniformFunc*, HsQMLUniformFunc*);+    ~HsQMLClass();+    const char* name();+    const HsQMLUniformFunc* methods();+    const HsQMLUniformFunc* properties();+    enum RefSrc {Handle, ObjProxy};+    void ref(RefSrc);+    void deref(RefSrc);++private:+    QAtomicInt mRefCount;+    unsigned int* mMetaData;+    char* mMetaStrData;+    HsQMLUniformFunc* mMethods;+    HsQMLUniformFunc* mProperties;++public:+    const int mMethodCount;+    const int mPropertyCount;+    const QMetaObject mMetaObject;+};++#endif /*HSQML_CLASS_H*/

+ cbits/HsQMLEngine.cpp view

@@ -0,0 +1,55 @@+#include "hsqml.h"+#include "HsQMLManager.h"+#include "HsQMLEngine.h"+#include "HsQMLObject.h"+#include "HsQMLWindow.h"++HsQMLEngine::HsQMLEngine(HsQMLEngineConfig& config)+{+    // Obtain, re-parent, and set QML global object+    if (config.contextObject) {+        QObject* contextObject = config.contextObject->object();+        contextObject->setParent(this);+        mEngine.rootContext()->setContextObject(contextObject);+    }++    // Create window+    HsQMLWindow* win = new HsQMLWindow(this);+    win->setSource(config.initialURL);+    win->setVisible(config.showWindow);+    if (config.setWindowTitle) {+        win->setTitle(config.windowTitle);+    }+    mWindows.insert(win);+}++HsQMLEngine::~HsQMLEngine()+{+}++QDeclarativeEngine* HsQMLEngine::engine()+{+    return &mEngine;+}++extern "C" void hsqml_create_engine(+    HsQMLObjectHandle* contextObject,+    HsQMLUrlHandle* initialURL,+    int showWindow,+    int setWindowTitle,+    HsQMLStringHandle* windowTitle)+{+    HsQMLEngineConfig config;+    config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);+    config.initialURL = *reinterpret_cast<QUrl*>(initialURL);+    config.showWindow = static_cast<bool>(showWindow);+    if (setWindowTitle) {+        config.setWindowTitle = true;+        config.windowTitle = *reinterpret_cast<QString*>(windowTitle);+    }++    Q_ASSERT (gManager);+    QMetaObject::invokeMethod(+        gManager, "createEngine", Qt::QueuedConnection,+        Q_ARG(HsQMLEngineConfig, config));+}

+ cbits/HsQMLEngine.h view

@@ -0,0 +1,41 @@+#ifndef HSQML_ENGINE_H+#define HSQML_ENGINE_H++#include <QSet>+#include <QString>+#include <QUrl>+#include <QDeclarativeEngine>++class HsQMLObjectProxy;+class HsQMLWindow;++struct HsQMLEngineConfig+{+    HsQMLEngineConfig()+        : contextObject(NULL)+        , showWindow(false)+        , setWindowTitle(false)+    {}++    HsQMLObjectProxy* contextObject;+    QUrl initialURL;+    bool showWindow;+    bool setWindowTitle;+    QString windowTitle;+};++class HsQMLEngine : public QObject+{+    Q_OBJECT++public:+    HsQMLEngine(HsQMLEngineConfig&);+    ~HsQMLEngine();+    QDeclarativeEngine* engine();++private:+    QDeclarativeEngine mEngine;+    QSet<HsQMLWindow*> mWindows;+};++#endif /*HSQML_ENGINE_H*/

+ cbits/HsQMLIntrinsics.cpp view

@@ -0,0 +1,77 @@+#include <cstdlib>+#include <cstring>++#include <QString>+#include <QUrl>++#include "hsqml.h"++/* String */+extern "C" size_t hsqml_get_string_size()+{+    return sizeof(QString);+}++extern "C" void hsqml_init_string(HsQMLStringHandle* hndl)+{+    new((void*)hndl) QString();+}++extern "C" void hsqml_deinit_string(HsQMLStringHandle* hndl)+{+    QString* string = (QString*)hndl;+    string->~QString();+}++extern "C" UTF16* hsqml_marshal_string(+    int bufLen, HsQMLStringHandle* hndl)+{+    QString* string = (QString*)hndl;+    string->resize(bufLen);+    return reinterpret_cast<UTF16*>(string->data());+}++extern "C" int hsqml_unmarshal_string(+    HsQMLStringHandle* hndl, UTF16** bufPtr)+{+    QString* string = (QString*)hndl;+    *bufPtr = reinterpret_cast<UTF16*>(string->data());+    return string->length();+}++/* URL */+extern "C" size_t hsqml_get_url_size()+{+    return sizeof(QUrl);+}++extern "C" void hsqml_init_url(HsQMLUrlHandle* hndl)+{+    new((void*)hndl) QUrl();+}++extern "C" void hsqml_deinit_url(HsQMLUrlHandle* hndl)+{+    QUrl* url = (QUrl*)hndl;+    url->~QUrl();+}++extern "C" void hsqml_marshal_url(+    char* buf, int bufLen, HsQMLUrlHandle* hndl)+{+    QUrl* url = (QUrl*)hndl;+    QByteArray cstr(buf, bufLen);+    url->setEncodedUrl(cstr, QUrl::StrictMode);+}++extern "C" int hsqml_unmarshal_url(+    HsQMLUrlHandle* hndl, char** bufPtr)+{+    QUrl* url = (QUrl*)hndl;+    QByteArray cstr = url->toEncoded();+    int bufLen = cstr.length();+    char* buf = reinterpret_cast<char*>(malloc(bufLen));+    memcpy(buf, cstr.data(), bufLen);+    *bufPtr = buf;+    return bufLen;+}

+ cbits/HsQMLManager.cpp view

@@ -0,0 +1,78 @@+#include <QMetaType>++#include "HsQMLManager.h"++QMutex gMutex;+HsQMLManager* gManager;+int gLogLevel;++HsQMLManager::HsQMLManager(+    int& argc,+    char** argv,+    void (*freeFun)(HsFunPtr),+    void (*freeStable)(HsStablePtr))+    : mApp(argc, argv)+    , mFreeFun(freeFun)+    , mFreeStable(freeStable)+{+}++HsQMLManager::~HsQMLManager()+{+}++void HsQMLManager::run()+{+    mApp.exec();++    // Delete engines once the event loop returns+    for (QVector<HsQMLEngine*>::iterator it = mEngines.begin();+            it != mEngines.end(); ++it) {+        delete *it;+    }+    mEngines.clear();+}++void HsQMLManager::freeFun(HsFunPtr funPtr)+{+    mFreeFun(funPtr);+}++void HsQMLManager::freeStable(HsStablePtr stablePtr)+{+    mFreeStable(stablePtr);+}++void HsQMLManager::createEngine(HsQMLEngineConfig config)+{+    mEngines.push_back(new HsQMLEngine(config));+}++extern "C" void hsqml_init(+    void (*free_fun)(HsFunPtr),+    void (*free_stable)(HsStablePtr))+{+    gMutex.lock();+    if (!gManager) {+        qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");++        int* argcp = new int[1];+        *argcp = 1;+        char** argv = new char*[1];+        argv[0] = new char[1];+        argv[0][0] = '\0';+        gManager = new HsQMLManager(*argcp, argv, free_fun, free_stable);+    }+    gMutex.unlock();+}++extern "C" void hsqml_run()+{+    Q_ASSERT (gManager);+    gManager->run();+}++extern "C" void hsqml_set_debug_loglevel(int level)+{+    gLogLevel = level;+}

+ cbits/HsQMLManager.h view

@@ -0,0 +1,42 @@+#ifndef HSQML_MANAGER_H+#define HSQML_MANAGER_H++#include <QApplication>+#include <QMutex>+#include <QVector>+#include <QUrl>++#include "hsqml.h"+#include "HsQMLEngine.h"++class HsQMLManager : public QObject+{+    Q_OBJECT++public:+    HsQMLManager(+        int& argc,+        char** argv,+        void (*)(HsFunPtr),+        void (*)(HsStablePtr));+    ~HsQMLManager();+    void run();+    void freeFun(HsFunPtr);+    void freeStable(HsStablePtr);+    Q_SLOT void createEngine(HsQMLEngineConfig);++private:+    HsQMLManager(const HsQMLManager&);+    HsQMLManager& operator=(const HsQMLManager&);++    QApplication mApp;+    QVector<HsQMLEngine*> mEngines;+    void (*mFreeFun)(HsFunPtr);+    void (*mFreeStable)(HsStablePtr);+};++extern QMutex gMutex;+extern HsQMLManager* gManager;+extern int gLogLevel;++#endif /*HSQML_MANAGER_H*/

+ cbits/HsQMLObject.cpp view

@@ -0,0 +1,199 @@+#include <HsFFI.h>+#include <QDeclarativeEngine>+#include <QString>+#include <QDebug>++#include "HsQMLObject.h"+#include "HsQMLClass.h"+#include "HsQMLManager.h"++HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)+    : mHaskell(haskell)+    , mKlass(klass)+    , mObject(NULL)+    , mRefCount(0)+{+    ref(Handle);+    mKlass->ref(HsQMLClass::ObjProxy);+}++HsQMLObjectProxy::~HsQMLObjectProxy()+{+    mKlass->deref(HsQMLClass::ObjProxy);+}++HsStablePtr HsQMLObjectProxy::haskell() const+{+    return mHaskell;+}++HsQMLClass* HsQMLObjectProxy::klass() const+{+    return mKlass;+}++HsQMLObject* HsQMLObjectProxy::object()+{+    if (!mObject) {+        mObject = new HsQMLObject(this);+    }+    return mObject;+}++void HsQMLObjectProxy::clearObject()+{+    mObject = NULL;+}++void HsQMLObjectProxy::ref(RefSrc src)+{+    int count = mRefCount.fetchAndAddOrdered(1);++    if (gLogLevel >= (count == 0 ? 3 : 4)) {+        qDebug() << QString().sprintf(+            "HsQML: %s ObjProxy, class=%s, ptr=%p, src=%d, count=%d.",+            count ? "Ref" : "New", mKlass->name(), this, src, count+1);+    }+}++void HsQMLObjectProxy::deref(RefSrc src)+{+    int count = mRefCount.fetchAndAddOrdered(-1);++    if (gLogLevel >= (count == 1 ? 3 : 4)) {+        qDebug() << QString().sprintf(+            "HsQML: %s ObjProxy, class=%s, ptr=%p, src=%d, count=%d.",+            count > 1 ? "Deref" : "Delete", mKlass->name(), this, src, count);+    }++    if (count == 1) {+        delete this;+    }+}++HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy)+    : mProxy(proxy)+    , mHaskell(proxy->haskell())+    , mKlass(proxy->klass())+{+    QDeclarativeEngine::setObjectOwnership(+        this, QDeclarativeEngine::JavaScriptOwnership);+    mProxy->ref(HsQMLObjectProxy::Object);+}++HsQMLObject::~HsQMLObject()+{+    mProxy->clearObject();+    mProxy->deref(HsQMLObjectProxy::Object);+}++const QMetaObject* HsQMLObject::metaObject() const+{+    return QObject::d_ptr->metaObject ?+        QObject::d_ptr->metaObject : &mKlass->mMetaObject;+}++void* HsQMLObject::qt_metacast(const char* clname)+{+    if (!clname) {+        return 0;+    }+    if (!strcmp(clname,+            mKlass->mMetaObject.d.stringdata ++            mKlass->mMetaObject.d.data[MD_CLASS_NAME])) {+        return static_cast<void*>(const_cast<HsQMLObject*>(this));+    }+    return QObject::qt_metacast(clname);+}++int HsQMLObject::qt_metacall(QMetaObject::Call c, int id, void** a)+{+    id = QObject::qt_metacall(c, id, a);+    if (id < 0) {+        return id;+    }+    if (QMetaObject::InvokeMetaMethod == c) {+        mKlass->methods()[id](this, a);+        id -= mKlass->mMethodCount;+    }+    else if (QMetaObject::ReadProperty == c) {+        mKlass->properties()[2*id](this, a);+        id -= mKlass->mPropertyCount;+    }+    else if (QMetaObject::WriteProperty == c) {+        HsQMLUniformFunc uf = mKlass->properties()[2*id+1];+        if (uf) {+            uf(this, a);+        }+        id -= mKlass->mPropertyCount;+    }+    else if (QMetaObject::QueryPropertyDesignable == c ||+             QMetaObject::QueryPropertyScriptable == c ||+             QMetaObject::QueryPropertyStored == c ||+             QMetaObject::QueryPropertyEditable == c ||+             QMetaObject::QueryPropertyUser == c) {+        id -= mKlass->mPropertyCount;+    }+    return id;+}++HsQMLObjectProxy* HsQMLObject::proxy() const+{+    return mProxy;+}++extern "C" HsQMLObjectHandle* hsqml_create_object(+    HsStablePtr haskell, HsQMLClassHandle* kHndl)+{+    HsQMLObjectProxy* proxy = new HsQMLObjectProxy(haskell, (HsQMLClass*)kHndl);+    return (HsQMLObjectHandle*)proxy;+}++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();+}++extern HsQMLObjectHandle* hsqml_get_object_handle(+    void* ptr, HsQMLClassHandle* klassHndl)+{+    // Return NULL if the input pointer is NULL+    if (!ptr) {+        return NULL;+    }++    // Return NULL if the object type doesn't match any supplied class+    if (klassHndl) {+        HsQMLClass* klass = (HsQMLClass*)klassHndl;+        QObject* qObj = static_cast<QObject*>(ptr);+        if (0 != strcmp(+            qObj->metaObject()->className(),+            klass->mMetaObject.className())) {+            return NULL;+        }+    }++    // Return object proxy+    HsQMLObject* object = (HsQMLObject*)ptr;+    HsQMLObjectProxy* proxy = object->proxy();+    proxy->ref(HsQMLObjectProxy::Handle);+    return (HsQMLObjectHandle*)proxy;+}++extern void hsqml_finalise_object_handle(+    HsQMLObjectHandle* hndl)+{+    if (hndl) {+        HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+        proxy->deref(HsQMLObjectProxy::Handle);+    }+}

+ cbits/HsQMLObject.h view

@@ -0,0 +1,45 @@+#ifndef HSQML_OBJECT_H+#define HSQML_OBJECT_H++#include <QObject>++class HsQMLClass;+class HsQMLObject;++class HsQMLObjectProxy+{+public:+    HsQMLObjectProxy(HsStablePtr, HsQMLClass*);+    virtual ~HsQMLObjectProxy();+    HsStablePtr haskell() const;+    HsQMLClass* klass() const;+    HsQMLObject* object();+    void clearObject();+    enum RefSrc {Handle, Object};+    void ref(RefSrc);+    void deref(RefSrc);++private:+    HsStablePtr mHaskell;+    HsQMLClass* mKlass;+    HsQMLObject* mObject;+    QAtomicInt mRefCount;+};++class HsQMLObject : public QObject+{+public:+    HsQMLObject(HsQMLObjectProxy*);+    virtual ~HsQMLObject();+    virtual const QMetaObject* metaObject() const;+    virtual void* qt_metacast(const char*);+    virtual int qt_metacall(QMetaObject::Call, int, void**);+    HsQMLObjectProxy* proxy() const;++private:+    HsQMLObjectProxy* mProxy;+    HsStablePtr mHaskell;+    HsQMLClass* mKlass;+};++#endif /*HSQML_OBJECT_H*/

+ cbits/HsQMLWindow.cpp view

@@ -0,0 +1,104 @@+#include "hsqml.h"+#include "HsQMLManager.h"+#include "HsQMLWindow.h"++HsQMLWindow::HsQMLWindow(HsQMLEngine* engine)+    : QObject(engine)+    , mEngine(engine)+    , mContext(engine->engine())+    , mView(&mScene)+    , mComponent(NULL)+{+    // Setup context+    mContext.setContextProperty("window", this);++    // Don't delete on close+    mWindow.setAttribute(Qt::WA_DeleteOnClose, false);++    // 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()+{+}++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->engine(), mSource, this);+        if (mComponent->isLoading()) {+            QObject::connect(+                mComponent,+                SIGNAL(statusChanged(QDeclarativeComponent::Status)),+                this,+                SLOT(completeSetSource()));+        }+        else {+            completeSetSource();+        }+    }+}++void HsQMLWindow::completeSetSource()+{+    QObject::disconnect(+        mComponent, SIGNAL(statusChanged(QDeclarativeComponent::Status)),+        this, SLOT(completeSetSource()));+    QDeclarativeItem* item =+        qobject_cast<QDeclarativeItem*>(mComponent->create(&mContext));+    if (item) {+        mScene.addItem(item);+    }+}++QString HsQMLWindow::title() const+{+    return mWindow.windowTitle();+}++void HsQMLWindow::setTitle(const QString& title)+{+    mWindow.setWindowTitle(title);+}++bool HsQMLWindow::visible() const+{+    return mWindow.isVisible();+}++void HsQMLWindow::setVisible(bool visible)+{+    mWindow.setVisible(visible);+}++void HsQMLWindow::close()+{+    QMetaObject::invokeMethod(+        this, "completeClose", Qt::QueuedConnection);+}++void HsQMLWindow::completeClose()+{+    delete this;+}

+ cbits/HsQMLWindow.h view

@@ -0,0 +1,45 @@+#ifndef HSQML_WINDOW_H+#define HSQML_WINDOW_H++#include <QMainWindow>+#include <QDeclarativeContext>+#include <QDeclarativeItem>+#include <QGraphicsScene>+#include <QGraphicsView>+#include <QUrl>++#include "HsQMLManager.h"++class QDeclarativeComponent;++class HsQMLWindow : public QObject+{+    Q_OBJECT++public:+    HsQMLWindow(HsQMLEngine*);+    virtual ~HsQMLWindow();+    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();+    Q_SLOT void completeClose();+    HsQMLEngine* mEngine;+    QDeclarativeContext mContext;+    QMainWindow mWindow;+    QGraphicsScene mScene;+    QGraphicsView mView;+    QUrl mSource;+    QDeclarativeComponent* mComponent;+};++#endif /*HSQML_WINDOW_H*/

+ cbits/hsqml.h view

@@ -0,0 +1,99 @@+#ifndef HSQML_H+#define HSQML_H++#ifdef __cplusplus+extern "C" {+#endif++#include <stddef.h>+#include <HsFFI.h>++/* Manager */+extern void hsqml_init(+    void (*)(HsFunPtr),+    void (*)(HsStablePtr));++extern void hsqml_run();++extern void hsqml_set_debug_loglevel(int);++/* String */+typedef char HsQMLStringHandle;++typedef unsigned short UTF16;++extern size_t hsqml_get_string_size();++extern void hsqml_init_string(+    HsQMLStringHandle*);++extern void hsqml_deinit_string(+    HsQMLStringHandle*);++extern UTF16* hsqml_marshal_string(+    int, HsQMLStringHandle*);++extern int hsqml_unmarshal_string(+    HsQMLStringHandle*, UTF16**);++/* URL */+typedef char HsQMLUrlHandle;++extern size_t hsqml_get_url_size();++extern void hsqml_init_url(+    HsQMLUrlHandle*);++extern void hsqml_deinit_url(+    HsQMLUrlHandle*);++extern void hsqml_marshal_url(+    char*, int, HsQMLUrlHandle*);++extern int hsqml_unmarshal_url(+    HsQMLUrlHandle*, char**);++/* Class */+typedef char HsQMLClassHandle;++typedef void (*HsQMLUniformFunc)(void*, void**);++extern int hsqml_get_next_class_id();++extern HsQMLClassHandle* hsqml_create_class(+    unsigned int*, char*, HsQMLUniformFunc*, HsQMLUniformFunc*);++extern void hsqml_finalise_class_handle(+    HsQMLClassHandle* hndl);++/* Object */+typedef char HsQMLObjectHandle;++extern HsQMLObjectHandle* hsqml_create_object(+    HsStablePtr, HsQMLClassHandle*);++extern HsStablePtr hsqml_object_get_haskell(+    HsQMLObjectHandle*);++extern void* hsqml_object_get_pointer(+    HsQMLObjectHandle*);++extern HsQMLObjectHandle* hsqml_get_object_handle(+    void*, HsQMLClassHandle*);++extern void hsqml_finalise_object_handle(+    HsQMLObjectHandle*);++/* Engine */+extern void hsqml_create_engine(+    HsQMLObjectHandle*,+    HsQMLUrlHandle*,+    int,+    int,+    HsQMLStringHandle*);++#ifdef __cplusplus+}+#endif++#endif /*HSQML_H*/

+ hsqml.cabal view

@@ -0,0 +1,84 @@+Name:               hsqml+Version:            0.1.0+Cabal-version:      >= 1.10+Build-type:         Custom+License:            BSD3+License-file:       LICENSE+Copyright:          (c) 2010-2012 Robin KAY+Author:             Robin KAY+Maintainer:         komadori@gekkou.co.uk+Stability:          experimental+Homepage:           http://www.gekkou.co.uk/+Category:           Graphics+Synopsis:           Haskell binding for Qt Quick+Extra-source-files: cbits/*.cpp cbits/*.h+Description:+    A Haskell binding for Qt Quick.++    General documentation is present in the 'Graphics.QML' module.++Library+    Default-language: Haskell2010+    Build-depends:+        base         == 4.*,+        containers   == 0.4.*,+        filepath     == 1.3.*,+        network      == 2.3.*,+        text         == 0.11.*,+        tagged       == 0.4.*,+        transformers >= 0.2 && < 0.4+    Exposed-modules:+        Graphics.QML+        Graphics.QML.Debug+        Graphics.QML.Engine+        Graphics.QML.Marshal+        Graphics.QML.Objects+    Other-modules:+        Graphics.QML.Internal.Marshal+        Graphics.QML.Internal.Objects+        Graphics.QML.Internal.PrimValues+        Graphics.QML.Internal.Engine+    Hs-source-dirs: src+    Cc-options: -std=c++0x+    C-sources:+        cbits/HsQMLClass.cpp+        cbits/HsQMLEngine.cpp+        cbits/HsQMLIntrinsics.cpp+        cbits/HsQMLManager.cpp+        cbits/HsQMLObject.cpp+        cbits/HsQMLWindow.cpp+    Include-dirs: cbits+    X-moc-headers:+        cbits/HsQMLEngine.h+        cbits/HsQMLManager.h+        cbits/HsQMLWindow.h+    X-separate-cbits: True+    Build-tools: c2hs+    if os(windows)+        Include-dirs:+            /QT_ROOT/include+            /QT_ROOT/include/QtCore+            /QT_ROOT/include/QtGui+            /QT_ROOT/include/QtDeclarative+        Extra-libraries: QtCore4, QtGui4, QtDeclarative4, stdc+++        Extra-lib-dirs:+            /SYS_ROOT/bin+            /QT_ROOT/bin+    else+        Pkgconfig-depends:+            QtDeclarative >= 4.7++Test-Suite hsqml-test1+    Type: exitcode-stdio-1.0+    Default-language: Haskell2010+    Hs-source-dirs: test+    Main-is: Test1.hs+    Build-depends:+        base      == 4.*,+        directory == 1.1.*,+        network   == 2.3.*,+        hsqml     == 0.1.*++Source-repository head+    type:     darcs+    location: https://patch-tag.com/r/komadori/HsQML

+ src/Graphics/QML.hs view

@@ -0,0 +1,45 @@+-- | This module imports the entire package, except 'Graphics.QML.Debug'.+module Graphics.QML (+-- * Overview+{-|+HsQML layers a low to medium level Haskell API on top of the C++ Qt Quick+framework. It allows you to write graphical applications where the front-end is +written in Qt Quick's QML language (incorporating JavaScript) and the back-end+is written in Haskell. To this end, this library provides two pieces of+functionality:-++The 'Graphics.QML.Engine' module allows you to create windows which host QML+content. You can specify a custom global object to be made available to the+JavaScript running inside the content. In this way, the content can interface+with the Haskell program.++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,+  module Graphics.QML.Objects+) where++import Graphics.QML.Engine+import Graphics.QML.Marshal+import Graphics.QML.Objects

+ src/Graphics/QML/Debug.hs view

@@ -0,0 +1,11 @@+-- | Debug Options+module Graphics.QML.Debug (+    setDebugLogLevel+) where++import Graphics.QML.Internal.Engine++-- | Sets the global debug log level. At level zero, no logging information+-- will be printed. Higher levels will increase debug verbosity.+setDebugLogLevel :: Int -> IO ()+setDebugLogLevel = hsqmlSetDebugLoglevel

+ src/Graphics/QML/Engine.hs view

@@ -0,0 +1,111 @@+{-# LANGUAGE+    ExistentialQuantification,+    Rank2Types+  #-}++-- | Functions for starting QML engines, displaying content in a window.+module Graphics.QML.Engine (+  InitialWindowState(+    ShowWindow,+    ShowWindowWithTitle,+    HideWindow),+  EngineConfig(+    EngineConfig,+    initialURL,+    initialWindowState,+    contextObject),+  defaultEngineConfig,+  createEngine,+  runEngines,+  filePathToURI+) where++import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Engine+import Graphics.QML.Marshal+import Graphics.QML.Objects++import Data.List+import Data.Maybe+import Data.Typeable+import Foreign.Storable+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 a = EngineConfig {+  -- | URL for the first QML document to be loaded.+  initialURL         :: URI,+  -- | Window state for the initial QML document.+  initialWindowState :: InitialWindowState,+  -- | Context 'Object' made available to QML script code.+  contextObject      :: Maybe (ObjRef a)+}++-- | Default engine configuration. Loads @\"main.qml\"@ from the current+-- working directory into a visible window with no context object.+defaultEngineConfig :: EngineConfig a+defaultEngineConfig = EngineConfig {+  initialURL         = nullURI {uriPath = "main.qml"},+  initialWindowState = ShowWindow,+  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++-- | Create a QML engine from a specification of its configuration.+createEngine :: (Object a) => EngineConfig a -> IO ()+createEngine config = do+  hsqmlInit+  let hndl = fmap (\(ObjRef h) -> h) $ contextObject config+      url = initialURL config+      state = initialWindowState config+      showWin = isWindowShown state+      maybeTitle = getWindowTitle state+      setTitle = isJust maybeTitle+      titleStr = fromMaybe "" maybeTitle+  mOutAlloc url $ \urlPtr -> do+    mOutAlloc titleStr $ \titlePtr -> do+      hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr++-- | Enters the Qt event loop and runs until all engines have terminated.+runEngines :: IO ()+runEngines = do+  hsqmlInit+  hsqmlRun++-- | Convenience function for converting local file paths into URIs.+filePathToURI :: FilePath -> URI+filePathToURI fp =+    let ds = splitDirectories fp+        abs = isAbsolute fp+        fixHead =+            (\cs -> if null cs then [] else '/':cs) .+            takeWhile (\c -> not $ c `elem` pathSeparators)+        mapHead _ [] = []+        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 "" ""

+ src/Graphics/QML/Internal/Engine.chs view

@@ -0,0 +1,48 @@+{-# LANGUAGE+    ForeignFunctionInterface+  #-}+{-# OPTIONS_HADDOCK hide #-}++module Graphics.QML.Internal.Engine where++{#import Graphics.QML.Internal.Objects #}++import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.StablePtr++#include <HsFFI.h>++#include "hsqml.h"++type HsFreeFunPtr = FunPtr (FunPtr (IO ()) -> IO ())+foreign import ccall "HsFFI.h &hs_free_fun_ptr"+  hsFreeFunPtr :: HsFreeFunPtr++type HsFreeStablePtr = FunPtr (Ptr () -> IO ())+foreign import ccall "HsFFI.h &hs_free_stable_ptr"+  hsFreeStablePtr :: HsFreeStablePtr++{#fun unsafe hsqml_init as hsqmlInit_+  {id `HsFreeFunPtr',+   id `HsFreeStablePtr'} ->+  `()' #}++hsqmlInit :: IO ()+hsqmlInit = hsqmlInit_ hsFreeFunPtr hsFreeStablePtr++{#fun unsafe hsqml_create_engine as ^+  {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle',+   castPtr `Ptr ()',+   fromBool `Bool',+   fromBool `Bool',+   castPtr `Ptr ()'} ->+  `()' #}++{#fun hsqml_run as ^ {} -> `()' #}++{#fun hsqml_set_debug_loglevel as ^+  {fromIntegral `Int'} -> `()'+  #}

+ src/Graphics/QML/Internal/Marshal.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE+    ScopedTypeVariables+  #-}++module Graphics.QML.Internal.Marshal where++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+}++-- | The class 'MarshalIn' allows QML values to be converted into Haskell+-- values.+class MarshalIn a where+  mIn :: InMarshaller a++type ErrIO a = MaybeT IO a++runErrIO :: ErrIO a -> IO ()+runErrIO m = do+  r <- runMaybeT m+  if isNothing r+  then hPutStrLn stderr "Warning: Marshalling error."+  else return ()++errIO :: IO a -> ErrIO a+errIO = MaybeT . fmap Just++-- | Encapsulates the functionality to needed to implement an instance of+-- 'MarshalIn' so that such instances can be defined without access to+-- implementation details.+data InMarshaller a = InMarshaller {+  mInFuncFld :: Ptr () -> ErrIO a,+  mIOTypeFld :: Tagged a TypeName+}++mInFunc :: (MarshalIn a) => Ptr () -> ErrIO a+mInFunc = mInFuncFld mIn ++mIOType :: (MarshalIn a) => Tagged a TypeName+mIOType = mIOTypeFld mIn++-- | The class 'MarshalOut' allows Haskell values to be converted into QML+-- values.+class (MarshalIn a) => MarshalOut a where+  mOutFunc  :: Ptr () -> a -> IO ()+  mOutAlloc :: a -> (Ptr () -> IO b) -> IO b++instance MarshalOut () where+  mOutFunc _ _ = return ()+  mOutAlloc _ f = f nullPtr++instance MarshalIn () where+  mIn = InMarshaller {+    mInFuncFld = \_ -> return (),+    mIOTypeFld = Tagged $ TypeName ""+  }

+ src/Graphics/QML/Internal/Objects.chs view

@@ -0,0 +1,143 @@+{-# LANGUAGE+    ForeignFunctionInterface+  #-}++module Graphics.QML.Internal.Objects where++import Foreign.C.Types+import Foreign.Ptr+import Foreign.ForeignPtr.Safe+import Foreign.ForeignPtr.Unsafe+import Foreign.StablePtr++#include "hsqml.h"++{#fun unsafe hsqml_get_next_class_id as ^+  {} ->+  `CInt' id #}++type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()++foreign import ccall "wrapper"  +  marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc)++{#pointer *HsQMLClassHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_class_handle"+  hsqmlFinaliseClassHandlePtr :: FunPtr (Ptr (HsQMLClassHandle) -> IO ())++newClassHandle :: Ptr HsQMLClassHandle -> IO (Maybe HsQMLClassHandle)+newClassHandle p =+  if nullPtr == p+    then return Nothing+    else do+      fp <- newForeignPtr hsqmlFinaliseClassHandlePtr p+      return $ Just $ HsQMLClassHandle fp++{#fun unsafe hsqml_create_class as ^+  {id `Ptr CUInt',+   id `Ptr CChar',+   id `Ptr (FunPtr UniformFunc)',+   id `Ptr (FunPtr UniformFunc)'} ->+  `Maybe HsQMLClassHandle' newClassHandle* #}++withMaybeHsQMLClassHandle ::+    Maybe HsQMLClassHandle -> (Ptr HsQMLClassHandle -> IO b) -> IO b+withMaybeHsQMLClassHandle (Just (HsQMLClassHandle fp)) = withForeignPtr fp+withMaybeHsQMLClassHandle Nothing = \f -> f nullPtr++withMaybeHsQMLObjectHandle ::+    Maybe HsQMLObjectHandle -> (Ptr HsQMLObjectHandle -> IO b) -> IO b+withMaybeHsQMLObjectHandle (Just (HsQMLObjectHandle fp)) = withForeignPtr fp+withMaybeHsQMLObjectHandle Nothing = \f -> f nullPtr++{#pointer *HsQMLObjectHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_object_handle"+  hsqmlFinaliseObjectHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ())++newObjectHandle :: Ptr HsQMLObjectHandle -> IO HsQMLObjectHandle+newObjectHandle p = do+  fp <- newForeignPtr hsqmlFinaliseObjectHandlePtr p+  return $ HsQMLObjectHandle fp++isNullObjectHandle :: HsQMLObjectHandle -> Bool+isNullObjectHandle (HsQMLObjectHandle fp) =+  nullPtr == unsafeForeignPtrToPtr fp++-- | Represents an instance of the QML class which wraps the type @tt@.+data ObjRef tt = ObjRef {+  objHndl :: HsQMLObjectHandle+}++objToPtr :: a -> (Ptr () -> IO b) -> IO b+objToPtr obj f = do+  sPtr <- newStablePtr obj+  res <- f $ castStablePtrToPtr sPtr+  return res++{#fun unsafe hsqml_create_object as ^+  {objToPtr* `a',+   withHsQMLClassHandle* `HsQMLClassHandle'} ->+  `HsQMLObjectHandle' newObjectHandle* #}++ptrToObj :: Ptr () -> IO a+ptrToObj =+  deRefStablePtr . castPtrToStablePtr++{#fun unsafe hsqml_object_get_haskell as ^+  {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+  `a' ptrToObj* #}++{#fun unsafe hsqml_object_get_pointer as ^+  {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+  `Ptr ()' id #}++{#fun unsafe hsqml_get_object_handle as ^+  {id `Ptr ()',+   withMaybeHsQMLClassHandle* `Maybe HsQMLClassHandle'} ->+  `HsQMLObjectHandle' newObjectHandle* #}++ofDynamicMetaObject :: CUInt+ofDynamicMetaObject = 0x01++mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask,+  mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor,+  mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable+  :: CUInt+mfAccessPrivate   = 0x00+mfAccessProtected = 0x01+mfAccessPublic    = 0x02+mfAccessMask      = 0x03+mfMethodMethod      = 0x00+mfMethodSignal      = 0x04+mfMethodSlot        = 0x08+mfMethodConstructor = 0x0c+mfMethodTypeMask    = 0x0c+mfMethodCompatibility = 0x10+mfMethodCloned        = 0x20+mfMethodScriptable    = 0x40++pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet,+  pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable,+  pfResolveScriptable, pfStored, pfResolveStored, pfEditable,+  pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt+pfInvalid           = 0x00000000+pfReadable          = 0x00000001+pfWritable          = 0x00000002+pfResettable        = 0x00000004+pfEnumOrFlag        = 0x00000008+pfStdCppSet         = 0x00000100+pfConstant          = 0x00000400+pfFinal             = 0x00000800+pfDesignable        = 0x00001000+pfResolveDesignable = 0x00002000+pfScriptable        = 0x00004000+pfResolveScriptable = 0x00008000+pfStored            = 0x00010000+pfResolveStored     = 0x00020000+pfEditable          = 0x00040000+pfResolveEditable   = 0x00080000+pfUser              = 0x00100000+pfResolveUser       = 0x00200000+pfNotify            = 0x00400000

+ src/Graphics/QML/Internal/PrimValues.chs view

@@ -0,0 +1,82 @@+{-# LANGUAGE+    ForeignFunctionInterface+  #-}++module Graphics.QML.Internal.PrimValues where++import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import System.IO.Unsafe++#include "hsqml.h"++cIntConv :: (Integral a, Integral b) => a -> b+cIntConv = fromIntegral++--+-- String+--++{#pointer *HsQMLStringHandle as ^ newtype #}++{#fun unsafe hsqml_get_string_size as ^+  {} ->+  `Int' fromIntegral #}++hsqmlStringSize :: Int+hsqmlStringSize = unsafePerformIO $ hsqmlGetStringSize++{#fun unsafe hsqml_init_string as ^+  {id `HsQMLStringHandle'} ->+  `()' #}++{#fun unsafe hsqml_deinit_string as ^+  {id `HsQMLStringHandle'} ->+  `()' #}++{#fun unsafe hsqml_marshal_string as ^+  {`Int',+   id `HsQMLStringHandle'} ->+  `Ptr CUShort' id #}++{#fun unsafe hsqml_unmarshal_string as ^+  {id `HsQMLStringHandle',+   id `Ptr (Ptr CUShort)'} ->+  `Int' #}++--+-- URL+--++{#pointer *HsQMLUrlHandle as ^ newtype #}++{#fun unsafe hsqml_get_url_size as ^+  {} ->+  `Int' fromIntegral #}++hsqmlUrlSize :: Int+hsqmlUrlSize = unsafePerformIO $ hsqmlGetUrlSize++{#fun unsafe hsqml_init_url as ^+  {id `HsQMLUrlHandle'} ->+  `()' #}++{#fun unsafe hsqml_deinit_url as ^+  {id `HsQMLUrlHandle'} ->+  `()' #}++{#fun unsafe hsqml_marshal_url as ^+  {id `Ptr CChar',+   `Int',+   id `HsQMLUrlHandle'} ->+  `()' #}++{#fun unsafe hsqml_unmarshal_url as ^+  {id `HsQMLUrlHandle',+   id `Ptr (Ptr CChar)'} ->+  `Int' #}

+ src/Graphics/QML/Marshal.hs view

@@ -0,0 +1,155 @@+{-# LANGUAGE+    ScopedTypeVariables,+    TypeSynonymInstances,+    FlexibleInstances+  #-}++-- | Type classs and instances for marshalling values between Haskell and QML.+module Graphics.QML.Marshal (+  MarshalIn (+    mIn),+  InMarshaller,+  MarshalOut+) where++import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.PrimValues++import Data.Maybe+import Data.Tagged+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Foreign as T+import Foreign.C.Types+import Foreign.C.String+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import Network.URI (+    URI (URI), URIAuth (URIAuth),+    parseURIReference, unEscapeString,+    uriToString, escapeURIString, nullURI,+    isUnescapedInURI)++--+-- Int/int built-in type+--++instance MarshalOut Int where+  mOutFunc ptr int =+    poke (castPtr ptr :: Ptr CInt) (fromIntegral int)+  mOutAlloc num f =+    alloca $ \(ptr :: Ptr CInt) ->+      mOutFunc (castPtr ptr) num >> f (castPtr ptr)++instance MarshalIn Int where+  mIn = InMarshaller {+    mInFuncFld = \ptr ->+      errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,+    mIOTypeFld = Tagged $ TypeName "int"+  }++--+-- Double/double built-in type+--++instance MarshalOut Double where+  mOutFunc ptr num =+    poke (castPtr ptr :: Ptr CDouble) (realToFrac num)+  mOutAlloc num f =+    alloca $ \(ptr :: Ptr CDouble) ->+      mOutFunc (castPtr ptr) num >> f (castPtr ptr)++instance MarshalIn Double where+  mIn = InMarshaller {+    mInFuncFld = \ptr ->+      errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,+    mIOTypeFld = Tagged $ TypeName "double"+  }++--+-- Text/QString built-in type+--++instance MarshalOut Text where+  mOutFunc ptr txt = do+    array <- hsqmlMarshalString+        (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)+    T.unsafeCopyToPtr txt (castPtr array)+  mOutAlloc txt f =+    allocaBytes hsqmlStringSize $ \ptr -> do+      hsqmlInitString $ HsQMLStringHandle ptr+      mOutFunc (castPtr ptr) txt+      ret <- f (castPtr ptr)+      hsqmlDeinitString $ HsQMLStringHandle ptr+      return ret++instance MarshalIn Text where+  mIn = InMarshaller {+    mInFuncFld = \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,+    mIOTypeFld = Tagged $ TypeName "QString"+  }++--+-- String/QString built-in type+--++instance MarshalOut String where+  mOutFunc ptr str = mOutFunc ptr $ T.pack str+  mOutAlloc txt f =+    allocaBytes hsqmlStringSize $ \ptr -> do+      hsqmlInitString $ HsQMLStringHandle ptr+      mOutFunc (castPtr ptr) txt+      ret <- f (castPtr ptr)+      hsqmlDeinitString $ HsQMLStringHandle ptr+      return ret++instance MarshalIn String where+  mIn = InMarshaller {+    mInFuncFld = fmap T.unpack . mInFuncFld mIn,+    mIOTypeFld = Tagged $ TypeName "QString"+  }++--+-- URI/QUrl built-in type+--++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 MarshalOut URI where+  mOutFunc ptr uri =+    let str = uriToString id (mapURIStrings+                (escapeURIString isUnescapedInURI) uri) ""+    in withCStringLen str (\(buf, bufLen) ->+         hsqmlMarshalUrl buf bufLen (HsQMLUrlHandle $ castPtr ptr))+  mOutAlloc uri f =+    allocaBytes hsqmlUrlSize $ \ptr -> do+      hsqmlInitUrl $ HsQMLUrlHandle ptr+      mOutFunc (castPtr ptr) uri+      ret <- f (castPtr ptr)+      hsqmlDeinitUrl $ HsQMLUrlHandle ptr+      return ret++instance MarshalIn URI where+  mIn = InMarshaller {+    mInFuncFld = \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,+    mIOTypeFld = Tagged $ TypeName "QUrl"+  }

+ src/Graphics/QML/Objects.hs view

@@ -0,0 +1,450 @@+{-# LANGUAGE+    ScopedTypeVariables,+    TypeFamilies,+    FlexibleContexts+  #-}++-- | Facilities for defining new object types which can be marshalled between+-- Haskell and QML.+module Graphics.QML.Objects (+  -- * Class Definition+  Object (+    classDef),+  ClassDef,+  Member,+  defClass,++  -- * Methods+  defMethod,+  MethodSuffix,++  -- * Properties+  defPropertyRO,+  defPropertyRW,++  -- * Object References+  ObjRef,+  newObject,+  fromObjRef,++  -- * Marshalling Type-classes+  objectInMarshaller,+  MarshalThis (+    type ThisObj,+    mThis),+  objectThisMarshaller+) where++import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Engine++import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.State+import Data.Bits+import Data.Char+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Tagged+import Data.Typeable+import Foreign.C.Types+import Foreign.C.String+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import System.IO.Unsafe+import Numeric++--+-- ObjRef+--++-- | The class 'MarshalThis' allows objects to be marshalled back into+-- Haskell as the \"this\" value for callbacks.+class (Object (ThisObj tt)) => MarshalThis tt where+  type ThisObj tt+  mThis :: ThisMarshaller tt++-- | Encapsulates the functionality to needed to implement an instance of+-- 'MarshalThis' so that such instances can be defined without access to+-- implementation details.+data ThisMarshaller tt = ThisMarshaller {+  mThisFuncFld :: Ptr () -> IO tt+}++mThisFunc :: (MarshalThis tt) => Ptr () -> IO tt+mThisFunc = mThisFuncFld mThis++instance (Object tt) => MarshalOut (ObjRef tt) where+  mOutFunc ptr obj = do+    objPtr <- hsqmlObjectGetPointer $ objHndl obj+    poke (castPtr ptr) objPtr+  mOutAlloc obj f =+    alloca $ \(ptr :: Ptr (Ptr ())) ->+      mOutFunc (castPtr ptr) obj >> f (castPtr ptr)++instance (Object tt) => MarshalIn (ObjRef tt) where+  mIn = InMarshaller {+    mInFuncFld = \ptr -> MaybeT $ do+      objPtr <- peek (castPtr ptr)+      hndl <- hsqmlGetObjectHandle objPtr $+        Just $ classHndl (classDefCAF :: ClassDef tt)+      return $ if isNullObjectHandle hndl+        then Nothing else Just $ ObjRef hndl,+    mIOTypeFld = Tagged $ TypeName "QObject*"+  }++instance (Object tt) => MarshalThis (ObjRef tt) where+  type ThisObj (ObjRef tt) = tt+  mThis = ThisMarshaller {+      mThisFuncFld = \ptr -> do+      hndl <- hsqmlGetObjectHandle ptr Nothing+      return $ ObjRef hndl+  }++retagType :: Tagged (ObjRef tt) TypeName -> Tagged tt TypeName+retagType = retag++-- | Provides an 'InMarshaller' which allows you to define instances of+-- 'MarshalIn' for custom object types. For example:+--+-- @+-- instance MarshalIn MyObjectType where+--     mIn = objectInMarshaller+-- @+--+-- This instance would allow @MyObjectType@ to be used as a parameter type+-- in callbacks. An instance is provided for @'ObjRef' MyObjectType@ by+-- default.+objectInMarshaller :: (Object tt) => InMarshaller tt+objectInMarshaller =+  InMarshaller {+    mInFuncFld = fmap fromObjRef . mInFunc,+    mIOTypeFld = retagType mIOType+  }++-- | Provides an 'ThisMarshaller' which allows you to define instances of+-- 'MarshalThis' for custom object types. For example:+--+-- @+-- instance MarshalThis MyObjectType where+--     type (ThisObj MyObjectType) = MyObjectType+--     mIn = objectInMarshaller+-- @+--+-- This instance would allow @MyObjectType@ to be used as the \"this\" type+-- for callbacks. An instance is provided for @'ObjRef' MyObjectType@ by+-- default.+objectThisMarshaller :: (Object tt, (ThisObj tt) ~ tt) => ThisMarshaller tt+objectThisMarshaller =+  ThisMarshaller {+    mThisFuncFld = fmap fromObjRef . mThisFunc+  }++-- | 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+  hndl <- hsqmlCreateObject obj $ classHndl (classDefCAF :: ClassDef tt)+  return $ ObjRef hndl++-- | Returns the associated value of the underlying Haskell type @tt@ from an+-- instance of the QML class which wraps it.+fromObjRef :: ObjRef tt -> tt+fromObjRef =+    unsafePerformIO . hsqmlObjectGetHaskell . objHndl++--+-- Object+--++-- | The class 'Object' allows Haskell types to expose an object-oriented+-- interface to QML. +class (Typeable tt) => Object tt where+  classDef :: ClassDef tt++-- | Uninlinable version of classDef to try and ensure that class definitions+-- get stored as constant applicable forms.+{-# NOINLINE classDefCAF #-}+classDefCAF :: (Object tt) => ClassDef tt+classDefCAF = classDef++--+-- ClassDef+--++-- | Represents the API of the QML class which wraps the type @tt@.+data ClassDef tt = ClassDef {+  classType :: TypeName,+  classHndl :: HsQMLClassHandle+}++-- | Generates a 'ClassDef' from a list of 'Member's.+defClass :: forall tt. (Object tt) => [Member tt] -> ClassDef tt+defClass ms = unsafePerformIO $ do+  let typ  = typeOf (undefined :: tt)+      con  = typeRepTyCon typ+      name = showString (tyConModule con) $ showChar '.' $ tyConName con+  id <- hsqmlGetNextClassId+  createClass (showString name $ showChar '_' $ showInt id "") ms++createClass :: forall tt. (Object tt) =>+  String -> [Member tt] -> IO (ClassDef tt)+createClass name ms = do+  let methods = methodMembers ms+      properties = propertyMembers ms+      (MOCOutput metaData metaStrData) = compileClass name methods properties+  metaDataPtr <- newArray metaData+  metaStrDataPtr <- newArray metaStrData+  methodsPtr <- mapM (marshalFunc . methodFunc) methods >>= newArray+  pReads <- mapM (marshalFunc . propertyReadFunc) properties+  pWrites <- mapM (fromMaybe (return nullFunPtr) . fmap marshalFunc .+    propertyWriteFunc) properties+  propertiesPtr <- newArray $ interleave pReads pWrites+  hsqmlInit+  hndl <- hsqmlCreateClass metaDataPtr metaStrDataPtr methodsPtr propertiesPtr+  return $ case hndl of +    Just hndl' -> ClassDef (TypeName name) hndl'+    Nothing    -> error ("Failed to create QML class '"++name++"'.")++interleave :: [a] -> [a] -> [a]+interleave [] ys = ys+interleave (x:xs) ys = x : ys `interleave` xs ++--+-- Member+--++-- | Represents a named member of the QML class which wraps type @tt@.+data Member tt+  -- | Constructs a 'Member' from a 'Method'.+  = MethodMember (Method tt)+  -- | Constructs a 'Member' from a 'Property'.+  | PropertyMember (Property tt)++-- | Returns the methods in a list of members.+methodMembers :: [Member tt] -> [Method tt]+methodMembers = mapMaybe f+  where f (MethodMember m) = Just m+        f _ = Nothing++-- | Returns the properties in a list of members.+propertyMembers :: [Member tt] -> [Property tt]+propertyMembers = mapMaybe f+  where f (PropertyMember m) = Just m+        f _ = Nothing++--+-- Method+--++-- | Represents a named method which can be invoked from QML on an object of+-- type @tt@.+data Method tt = Method {+  -- | Gets the name of a 'Method'.+  methodName  :: String,+  -- | Gets the 'TypeName's which comprise the signature of a 'Method'.+  -- The head of the list is the return type and the tail the arguments.+  methodTypes :: [TypeName],+  methodFunc  :: UniformFunc+}++data CrudeMethodTypes = CrudeMethodTypes {+    methodParamTypes :: [TypeName],+    methodReturnType :: TypeName+  }++crudeTypesToList :: CrudeMethodTypes -> [TypeName]+crudeTypesToList (CrudeMethodTypes p r) = r:p++-- | Supports marshalling Haskell functions with an arbitrary number of+-- arguments.+class MethodSuffix a where+  mkMethodFunc  :: Int -> a -> Ptr (Ptr ()) -> ErrIO ()+  mkMethodTypes :: Tagged a CrudeMethodTypes++instance (MarshalIn a, MethodSuffix b) => MethodSuffix (a -> b) where+  mkMethodFunc n f pv = do+    ptr <- errIO $ peekElemOff pv n+    val <- mInFunc ptr+    mkMethodFunc (n+1) (f val) pv+    return ()+  mkMethodTypes =+    let (CrudeMethodTypes p r) =+          untag (mkMethodTypes :: Tagged b CrudeMethodTypes)+        ty = untag (mIOType :: Tagged a TypeName)+    in Tagged $ CrudeMethodTypes (ty:p) r++instance (MarshalOut a) => MethodSuffix (IO a) where+  mkMethodFunc _ f pv = errIO $ do+    ptr <- peekElemOff pv 0+    val <- f+    if nullPtr == ptr+    then return ()+    else mOutFunc ptr val+  mkMethodTypes =+    let ty = untag (mIOType :: Tagged a TypeName)+    in Tagged $ CrudeMethodTypes [] ty++mkUniformFunc :: forall tt ms. (MarshalThis tt, MethodSuffix ms) =>+  (tt -> ms) -> UniformFunc+mkUniformFunc f = \pt pv -> do+  this <- mThisFunc pt+  runErrIO $ mkMethodFunc 1 (f this) pv++-- | Defines a named method using a function @f@ in the IO monad.+--+-- The first argument to @f@ receives the \"this\" object and hence must match+-- the type of the class on which the method is being defined. Subsequently,+-- there may be zero or more parameter arguments followed by an optional return+-- argument in the IO monad. These argument types must be members of the+-- 'MarshalThis', 'MarshalIn', and 'MarshalOut' typeclasses respectively.++defMethod ::+  forall tt ms. (MarshalThis tt, MethodSuffix ms) =>+  String -> (tt -> ms) -> Member (ThisObj tt)+defMethod name f = MethodMember $ Method name+  (crudeTypesToList $ untag (mkMethodTypes :: Tagged ms CrudeMethodTypes))+  (mkUniformFunc f)++--+-- Property+--++-- | Represents a named property which can be accessed from QML on an object+-- of type @tt@.+data Property tt = Property {+  -- | Gets the name of a 'Property'.+  propertyName :: String,+  propertyType :: TypeName,+  propertyReadFunc :: UniformFunc,+  propertyWriteFunc :: Maybe UniformFunc+}++-- | Defines a named read-only property using an accessor function in the IO+-- monad.+defPropertyRO ::+  forall tt tr. (MarshalThis tt, MarshalOut tr) =>+  String -> (tt -> IO tr) -> Member (ThisObj tt)+defPropertyRO name g = PropertyMember $ Property name+  (untag (mIOType :: Tagged tr TypeName))+  (mkUniformFunc g)+  Nothing++-- | Defines a named read-write property using a pair of accessor and mutator+-- functions in the IO monad.+defPropertyRW ::+  forall tt tr. (MarshalThis tt, MarshalOut tr) =>+  String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (ThisObj tt)+defPropertyRW name g s = PropertyMember $ Property name+  (untag (mIOType :: Tagged tr TypeName))+  (mkUniformFunc g)+  (Just $ mkUniformFunc s)++--+-- Meta Object Compiler+--++data MOCState = MOCState {+  mData            :: [CUInt],+  mDataLen         :: Int,+  mDataMethodsIdx  :: Maybe Int,+  mDataPropsIdx    :: Maybe Int,+  mStrData         :: [CChar],+  mStrDataLen      :: Int,+  mStrDataMap      :: Map String CUInt+} deriving Show++data MOCOutput = MOCOutput [CUInt] [CChar]++newMOCState :: MOCState+newMOCState = MOCState [] 0 Nothing Nothing [] 0 Map.empty++writeInt :: CUInt -> State MOCState ()+writeInt int = do+  state <- get+  let md    = mData state+      mdLen = mDataLen state+  put $ state {mData = int:md, mDataLen = mdLen+1}+  return ()++writeString :: String -> State MOCState ()+writeString str = do+  state <- get+  let msd    = mStrData state+      msdLen = mStrDataLen state+      msdMap = mStrDataMap state+  case (Map.lookup str msdMap) of+    Just idx -> writeInt idx+    Nothing  -> do+      let idx = fromIntegral msdLen+          msd' = 0 : (map castCharToCChar (reverse str) ++ msd)+          msdLen' = msdLen + length str + 1+          msdMap' = Map.insert str idx msdMap+      put $ state {+        mStrData = msd',+        mStrDataLen = msdLen',+        mStrDataMap = msdMap'}+      writeInt idx++writeMethod :: Method tt -> State MOCState ()+writeMethod m = do+  idx <- get >>= return . mDataLen+  writeString $ methodSignature m+  writeString $ methodParameters m+  writeString $ typeName $ head $ methodTypes m+  writeString ""+  writeInt (mfAccessPublic .|. mfMethodScriptable)+  state <- get+  put $ state {mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx)}+  return ()++writeProperty :: Property tt -> State MOCState ()+writeProperty p = do+  idx <- get >>= return . mDataLen+  writeString $ propertyName p+  writeString $ typeName $ propertyType p+  writeInt (pfReadable .|. pfScriptable .|.+    if (isJust $ propertyWriteFunc p) then pfWritable else 0)+  state <- get+  put $ state {mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx)}+  return ()++compileClass :: String -> [Method tt] -> [Property tt] -> MOCOutput+compileClass name ms ps = +  let enc = flip execState newMOCState $ do+        writeInt 5                           -- Revision+        writeString name                     -- Class name+        writeInt 0 >> writeInt 0             -- Class info+        writeInt $ fromIntegral $ length ms  -- Methods+        writeInt $ fromIntegral $+          fromMaybe 0 $ mDataMethodsIdx enc  -- Methods (data index)+        writeInt $ fromIntegral $ length ps  -- Properties+        writeInt $ fromIntegral $+          fromMaybe 0 $ mDataPropsIdx enc    -- Properties (data index)+        writeInt 0 >> writeInt 0             -- Enums+        writeInt 0 >> writeInt 0             -- Constructors+        writeInt 0                           -- Flags+        writeInt 0                           -- Signals        +        mapM_ writeMethod ms+        mapM_ writeProperty ps+        writeInt 0+  in MOCOutput (reverse $ mData enc) (reverse $ mStrData enc)++foldr0 :: (a -> a -> a) -> a -> [a] -> a+foldr0 _ x [] = x+foldr0 f _ xs = foldr1 f xs++methodSignature :: Method tt -> String+methodSignature method =+  let paramTypes = tail $ methodTypes method+  in (showString (methodName method) . showChar '(' .+       foldr0 (\l r -> l . showChar ',' . r) id+         (map (showString . typeName) paramTypes) . showChar ')') ""++methodParameters :: Method tt -> String+methodParameters method =+  replicate (flip (-) 2 $ length $ methodTypes method) ','

+ test/Test1.hs view

@@ -0,0 +1,148 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Graphics.QML+import Control.Monad+import Data.IORef+import Data.List+import Data.Maybe+import Data.Typeable+import Network.URI+import System.Exit+import System.IO+import System.Directory++data HarnessObject = HarnessObject {+    globalState :: IORef [String]+} deriving Typeable++markTaskComplete :: HarnessObject -> String -> IO ()+markTaskComplete go task = do+    let ref = globalState go+    list <- readIORef ref+    if elem task list+    then do+        putStrLn (+            showString "Completed task '" .+            showString task $ showString "'." [])+        writeIORef ref $ delete task list+    else do+        putStrLn (showString "Unexpected task '" .+            showString task $ showString "' completed." [])+        writeIORef ref $ ("unexpected_" ++ task) : list++testInt :: Int+testInt = 8888++testDouble :: Double+testDouble = 0.25++testString :: String+testString = "我係QuickBrownFox"++testURI :: URI+testURI =+    URI "http:" (Just $ URIAuth "" "www.example.com" "")+        "/with space" "" "#test"++data TestObject = TestObject deriving (Eq, Typeable)++instance Object TestObject where+    classDef = defClass []++instance MarshalIn TestObject where+    mIn = objectInMarshaller++instance Object HarnessObject where+    classDef = defClass [+        defMethod "getInt" (\go -> do+            markTaskComplete (fromObjRef go) "getInt"+            return testInt),+        defMethod "setInt" (\go i -> do+            markTaskComplete (fromObjRef go) "setInt"+            if (i == testInt)+            then markTaskComplete (fromObjRef go) "setIntCorrect"+            else return ()),+        defMethod "getDouble" (\go -> do+            markTaskComplete (fromObjRef go) "getDouble"+            return testDouble),+        defMethod "setDouble" (\go i -> do+            markTaskComplete (fromObjRef go) "setDouble"+            if (i == testDouble)+            then markTaskComplete (fromObjRef go) "setDoubleCorrect"+            else return ()),+        defMethod "getString" (\go -> do+            markTaskComplete (fromObjRef go) "getString"+            return testString),+        defMethod "setString" (\go i -> do+            markTaskComplete (fromObjRef go) "setString"+            if (i == testString)+            then markTaskComplete (fromObjRef go) "setStringCorrect"+            else return ()),+        defMethod "getURI" (\go -> do+            markTaskComplete (fromObjRef go) "getURI"+            return testURI),+        defMethod "setURI" (\go i -> do+            markTaskComplete (fromObjRef go) "setURI"+            if (i == testURI)+            then markTaskComplete (fromObjRef go) "setURICorrect"+            else return ()),+        defMethod "getObject" (\go -> do+            markTaskComplete (fromObjRef go) "getObject"+            newObject TestObject),+        defMethod "setObject" (\go i -> do+            markTaskComplete (fromObjRef go) "setObject"+            if (i == TestObject)+            then markTaskComplete (fromObjRef go) "setObjectCorrect"+            else return ())]++testScript :: String+testScript = unlines [+    "import Qt 4.7",+    "Rectangle {",+    "    id: page;",+    "    width: 100; height: 100;",+    "    color: 'green';",+    "    Component.onCompleted: {",+    "        var intVar = getInt();",+    "        setInt(intVar);",+    "        var dblVar = getDouble();",+    "        setDouble(dblVar);",+    "        var strVar = getString();",+    "        setString(strVar);",+    "        var uriVar = getURI();",+    "        setURI(uriVar);",+    "        var objVar = getObject();",+    "        setObject(objVar);",+    "        window.close();",+    "    }",+    "}"]++testTasks :: [String]+testTasks = [+    "getInt", "setInt", "setIntCorrect",+    "getDouble", "setDouble", "setDoubleCorrect",+    "getString", "setString", "setStringCorrect",+    "getURI", "setURI", "setURICorrect",+    "getObject", "setObject", "setObjectCorrect"]++main :: IO ()+main = do+    tmpDir <- getTemporaryDirectory+    (qmlPath, hndl) <- openTempFile tmpDir "test1-.qml"+    hPutStr hndl testScript+    hClose hndl+    list <- newIORef testTasks+    go <- newObject $ HarnessObject list+    createEngine defaultEngineConfig {+        initialURL = fromJust $ parseURIReference qmlPath,+        contextObject = Just go}+    runEngines+    removeFile qmlPath+    ts <- readIORef list+    forM_ ts (\t -> putStrLn (+        showString "Incomplete task '" . showString t $ showString "'." []))+    if null ts+    then exitSuccess+    else exitFailure