hsqml 0.3.5.1 → 0.3.6.0
raw patch · 16 files changed
+295/−93 lines, 16 filesdep +bytestringdep ~QuickCheckdep ~containersdep ~directorysetup-changednew-uploader
Dependencies added: bytestring
Dependency ranges changed: QuickCheck, containers, directory, filepath, tagged, text, transformers
Files
- README +0/−9
- README.md +13/−0
- Setup.hs +54/−26
- cbits/ClipboardHelper.cpp +9/−0
- cbits/ClipboardHelper.h +16/−0
- cbits/HighDpiScaling.cpp +5/−0
- cbits/HighDpiScaling.h +9/−0
- cbits/Manager.cpp +63/−0
- cbits/Manager.h +4/−0
- cbits/Model.cpp +1/−0
- cbits/hsqml.h +1/−0
- hsqml.cabal +58/−29
- src/Graphics/QML/Engine.hs +25/−4
- src/Graphics/QML/Internal/Marshal.hs +6/−4
- src/Graphics/QML/Marshal.hs +15/−8
- src/Graphics/QML/Objects.hs +16/−13
− README
@@ -1,9 +0,0 @@-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
+ README.md view
@@ -0,0 +1,13 @@+# HsQML++[](https://github.com/prolic/HsQML/actions?query=workflow%3ATests)+[](https://ci.appveyor.com/project/prolic/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++**Note:** I made some changes, so this library works on newer GHC / cabal versions and has been tested on Qt5.
Setup.hs view
@@ -14,10 +14,12 @@ import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program+import Distribution.Simple.Program.Ar import Distribution.Simple.Program.Ld import Distribution.Simple.Register import Distribution.Simple.Setup import Distribution.Simple.Utils+import Distribution.System import Distribution.Text import Distribution.Types.CondTree import Distribution.Types.LocalBuildInfo@@ -25,7 +27,10 @@ import System.Environment import System.FilePath+import System.Info (os) +import Text.Read (readMaybe)+ main :: IO () main = do -- If system uses qtchooser(1) then encourage it to choose Qt 5@@ -86,14 +91,32 @@ mapAllBI mocPath cppPath = mapSnd $ mapCondTree (mapBI $ substPaths mocPath cppPath) id id +-- Helper function to map over PerCompilerFlavor+mapPerCompilerFlavor :: (String -> String) -> PerCompilerFlavor [String] -> PerCompilerFlavor [String]+mapPerCompilerFlavor f (PerCompilerFlavor gcc other) = PerCompilerFlavor (map f gcc) (map f other)++-- Function to replace paths and options in BuildInfo substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo substPaths mocPath cppPath build =- let escapeStr = init . tail . show- toRoot = escapeStr . takeDirectory . takeDirectory . fromMaybe ""- in read .- replace "/QT_ROOT" (toRoot mocPath) .- replace "/SYS_ROOT" (toRoot cppPath) .- replace "-hide-option-" "-" $ show build+ let toRoot path = takeDirectory (takeDirectory (fromMaybe "" path))+ qtRoot = toRoot mocPath+ sysRoot = toRoot cppPath+ replacePath :: FilePath -> FilePath+ replacePath path+ | "/QT_ROOT" `isPrefixOf` path = qtRoot ++ drop (length "/QT_ROOT") path+ | "/SYS_ROOT" `isPrefixOf` path = sysRoot ++ drop (length "/SYS_ROOT") path+ | otherwise = path+ replaceOption opt+ | "-hide-option-" `isPrefixOf` opt = "-" ++ drop (length "-hide-option-") opt+ | otherwise = opt+ in build {+ includeDirs = map replacePath (includeDirs build),+ extraLibDirs = map replacePath (extraLibDirs build),+ ccOptions = map replacePath (ccOptions build),+ cppOptions = map replaceOption (cppOptions build),+ extraFrameworkDirs = map replacePath (extraFrameworkDirs build),+ sharedOptions = mapPerCompilerFlavor replaceOption (sharedOptions build)+ } buildWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()@@ -140,32 +163,37 @@ name = unPackageName $ pkgName pid in pid {pkgName = mkPackageName $ "cbits-" ++ name} -mkGHCiFixLibName :: PackageDescription -> String-mkGHCiFixLibName pkgDesc =- ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension+mkGHCiFixLibName :: PackageDescription -> Platform -> String+mkGHCiFixLibName pkgDesc platform =+ ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension platform -mkGHCiFixLibRefName :: PackageDescription -> String-mkGHCiFixLibRefName pkgDesc =+mkGHCiFixLibRefName :: PackageDescription -> Platform -> String+mkGHCiFixLibRefName pkgDesc platform = prefix ++ display (mkGHCiFixLibPkgId pkgDesc)- where prefix = if dllExtension == "dll" then "lib" else ""+ where prefix = if dllExtension platform == "dll" then "lib" else "" buildGHCiFix :: Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> IO () buildGHCiFix verb pkgDesc lbi lib = let bDir = buildDir lbi- clbis = componentNameCLBIs lbi CLibName+ clbis = componentNameCLBIs lbi (CLibName $ libName lib)+ platform = hostPlatform lbi in flip mapM_ clbis $ \clbi -> do let ms = map ModuleName.toFilePath $ allLibModules lib clbi hsObjs = map ((bDir </>) . (<.> "o")) ms lname = getHSLibraryName $ componentUnitId clbi stubObjs <- fmap catMaybes $ mapM (findFileWithExtension ["o"] [bDir]) $ map (++ "_stub") ms- (ld,_) <- requireProgram verb ldProgram (withPrograms lbi)- combineObjectFiles verb ld (bDir </> lname <.> "o") (stubObjs ++ hsObjs)+ case os of+ "mingw32" -> do+ createArLibArchive verb lbi (bDir </> lname <.> "a") (stubObjs ++ hsObjs)+ _ -> do+ (ld,_) <- requireProgram verb ldProgram (withPrograms lbi)+ combineObjectFiles verb lbi ld (bDir </> lname <.> "o") (stubObjs ++ hsObjs) (ghc,_) <- requireProgram verb ghcProgram (withPrograms lbi) let bi = libBuildInfo lib runProgram verb ghc (- ["-shared","-o",bDir </> (mkGHCiFixLibName pkgDesc)] +++ ["-shared","-o",bDir </> (mkGHCiFixLibName pkgDesc platform)] ++ (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) ++ (map ("-L" ++) $ extraLibDirs bi) ++ (map ((bDir </>) . flip replaceExtension objExtension) $ cSources bi))@@ -177,13 +205,13 @@ programFindLocation = \verb search -> fmap msum $ mapM (findProgramOnSearchPath verb search) ["moc-qt5", "moc"], programFindVersion = \verb path -> do- (oLine,eLine,_) <-- rawSystemStdInOut verb path ["-v"] Nothing Nothing Nothing False- return $- msum (map (\(p,l) -> findSubseq (stripPrefix p) l)- [("(Qt ",eLine), ("moc-qt5 ",oLine), ("moc ",oLine)]) >>=- simpleParse . takeWhile (\c -> isDigit c || c == '.'),- programPostConf = \_ c -> return c+ (oLine, eLine, _) <- rawSystemStdInOut verb path ["-v"] Nothing Nothing Nothing IODataModeText+ return $+ msum (map (\(p, l) -> findSubseq (stripPrefix p) l)+ [("(Qt ", eLine), ("moc-qt5 ", oLine), ("moc ", oLine)]) >>=+ simpleParse . takeWhile (\c -> isDigit c || c == '.'),+ programPostConf = \_ c -> return c,+ programNormaliseArgs = \_ _ args -> args } qtVersionRange :: VersionRange@@ -198,7 +226,7 @@ dest = fromFlag $ copyDest flags bDir = buildDir lbi instDirs = absoluteInstallDirs pkgDesc lbi dest- file = mkGHCiFixLibName pkgDesc+ file = mkGHCiFixLibName pkgDesc (hostPlatform lbi) when (needsGHCiFix pkgDesc lbi) $ do installOrdinaryFile verb (bDir </> file) (dynlibdir instDirs </> file) -- Stack looks in the non-dyn lib directory@@ -212,7 +240,7 @@ dist = fromFlag $ regDistPref flags reloc = relocatable lbi pkgDb = withPackageDB lbi- clbis = componentNameCLBIs lbi CLibName+ clbis = componentNameCLBIs lbi (CLibName $ libName lib) regDb <- fmap registrationPackageDB $ absolutePackageDBPaths pkgDb flip mapM_ clbis $ \clbi -> do instPkgInfo <-@@ -220,7 +248,7 @@ let instPkgInfo' = instPkgInfo { -- Add extra library for GHCi workaround I.extraGHCiLibraries =- (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg] else []) +++ (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg (hostPlatform lbi)] else []) ++ I.extraGHCiLibraries instPkgInfo, -- Add directories to framework search path I.frameworkDirs =
+ cbits/ClipboardHelper.cpp view
@@ -0,0 +1,9 @@+#include "ClipboardHelper.h"++HsQMLClipboardHelper::HsQMLClipboardHelper(QObject *parent)+ : QObject(parent) {}++void HsQMLClipboardHelper::copyText(const QString &text) {+ QClipboard *clipboard = QGuiApplication::clipboard();+ clipboard->setText(text);+}
+ cbits/ClipboardHelper.h view
@@ -0,0 +1,16 @@+#ifndef CLIPBOARDHELPER_H+#define CLIPBOARDHELPER_H++#include <QtGui/QGuiApplication>+#include <QtGui/QClipboard>+#include <QtCore/QObject>++class HsQMLClipboardHelper : public QObject {+ Q_OBJECT+public:+ explicit HsQMLClipboardHelper(QObject *parent = nullptr);++ Q_INVOKABLE void copyText(const QString &text);+};++#endif // CLIPBOARDHELPER_H
+ cbits/HighDpiScaling.cpp view
@@ -0,0 +1,5 @@+#include "QtGui/QGuiApplication"++extern "C" void hsqml_enable_high_dpi_scaling() {+ QGuiApplication::setAttribute(Qt::AA_EnableHighDpiScaling);+}
+ cbits/HighDpiScaling.h view
@@ -0,0 +1,9 @@+#ifdef __cplusplus+extern "C" {+#endif++void hsqml_enable_high_dpi_scaling();++#ifdef __cplusplus+}+#endif
cbits/Manager.cpp view
@@ -4,12 +4,19 @@ #include <QtCore/QMetaType> #include <QtCore/QMutexLocker> #include <QtCore/QThread>+#include <QtQml/QQmlDebuggingEnabler>+#include <QtCore/QDebug>+#include <QtCore/QProcessEnvironment>+#include <QtCore/QLoggingCategory>+#include <QtNetwork/QTcpServer>+#include <QtNetwork/QTcpSocket> #ifdef Q_OS_MAC #include <pthread.h> #endif #include "Canvas.h" #include "Class.h"+#include "ClipboardHelper.h" #include "Engine.h" #include "Manager.h" #include "Model.h"@@ -87,6 +94,7 @@ , mJobsCb(NULL) , mYieldCb(NULL) , mActiveEngine(NULL)+ , mQmlDebugEnabled(false) { // Set default Qt args setArgs(QStringList("HsQML"));@@ -171,6 +179,9 @@ QCoreApplication::setAttribute(Qt::AA_ShareOpenGLContexts, value); return true; #endif+ case HSQML_GFLAG_ENABLE_QML_DEBUG:+ mQmlDebugEnabled = value;+ return true; } return false; }@@ -182,6 +193,8 @@ case HSQML_GFLAG_SHARE_OPENGL_CONTEXTS: return QCoreApplication::testAttribute(Qt::AA_ShareOpenGLContexts); #endif+ case HSQML_GFLAG_ENABLE_QML_DEBUG:+ return mQmlDebugEnabled; } return false; }@@ -417,6 +430,33 @@ , mApp(mArgC, gManager->argsPtrs().data()) { gManager->argsPtrs().resize(mArgC);++ // Only enable debugging if the flag is set+ if (gManager->getFlag(HSQML_GFLAG_ENABLE_QML_DEBUG)) {+ QQmlDebuggingEnabler enabler(true);++ const QString configString = QString::fromLatin1("port:3768,block=true");++ bool debugServerStarted = QQmlDebuggingEnabler::startTcpDebugServer(+ 3768,+ QQmlDebuggingEnabler::WaitForClient,+ configString+ );++ qDebug() << "QML debugging server started:" << (debugServerStarted ? "yes" : "no")+ << "with config:" << configString;++ // Check if the port is available+ QTcpServer server;+ if (!server.listen(QHostAddress::LocalHost, 3768)) {+ qDebug() << "Debug port 3768 is not available:" << server.errorString();+ qDebug() << "Port might be in use. Try: lsof -i :3768";+ } else {+ server.close();+ qDebug() << "Debug port 3768 is available";+ }+ }+ mApp.setQuitOnLastWindowClosed(false); // Install hooked handler for QVariants@@ -430,6 +470,8 @@ "HsQML.Canvas", 1, 0, "OpenGLContextControl"); qmlRegisterType<HsQMLAutoListModel>( "HsQML.Model", 1, 0, "AutoListModel");+ qmlRegisterType<HsQMLClipboardHelper>(+ "HsQML.Clipboard", 1, 0, "ClipboardHelper"); } HsQMLManagerApp::~HsQMLManagerApp()@@ -484,6 +526,21 @@ return mApp.exec(); } +void HsQMLManagerApp::setWindowIcon(QIcon* icon)+{+ if (icon != nullptr) {+ mApp.setWindowIcon(*icon);+ delete icon;+ }+}++void HsQMLManager::setWindowIcon(const QString& iconPath)+{+ if (mApp != nullptr) {+ mApp->setWindowIcon(new QIcon(iconPath));+ }+}+ extern "C" void hsqml_init( void (*freeFun)(HsFunPtr), void (*freeStable)(HsStablePtr))@@ -566,4 +623,10 @@ { Q_ASSERT (gManager); gManager->setLogLevel(ll);+}++extern "C" void hsqml_set_window_icon(const char* iconPath) {+ if (gManager) {+ gManager->setWindowIcon(QString::fromUtf8(iconPath));+ } }
cbits/Manager.h view
@@ -11,6 +11,7 @@ #include <QtCore/QVariant> #include <QtCore/QVector> #include <QtWidgets/QApplication>+#include <QtGui/QIcon> #include "hsqml.h" @@ -64,6 +65,7 @@ void postAppEvent(QEvent*); void zombifyClass(HsQMLClass*); EventLoopStatus shutdown();+ void setWindowIcon(const QString& iconPath); private: friend class HsQMLManagerApp;@@ -90,6 +92,7 @@ HsQMLTrivialCb mJobsCb; HsQMLTrivialCb mYieldCb; HsQMLEngine* mActiveEngine;+ bool mQmlDebugEnabled; }; class HsQMLManagerApp : public QObject@@ -101,6 +104,7 @@ virtual ~HsQMLManagerApp(); virtual void customEvent(QEvent*); virtual void timerEvent(QTimerEvent*);+ virtual void setWindowIcon(QIcon*); int exec(); enum CustomEventIndicies {
cbits/Model.cpp view
@@ -1,4 +1,5 @@ #include <QtCore/QMultiHash>+#include <QtCore/QDebug> #include "Model.h" #include "Manager.h"
cbits/hsqml.h view
@@ -198,6 +198,7 @@ typedef enum { HSQML_GFLAG_SHARE_OPENGL_CONTEXTS,+ HSQML_GFLAG_ENABLE_QML_DEBUG, } HsQMLGlobalFlag; extern int hsqml_set_flag(HsQMLGlobalFlag, int);
hsqml.cabal view
@@ -1,24 +1,35 @@+cabal-version: 3.8 Name: hsqml-Version: 0.3.5.1-Cabal-version: >= 1.24+Version: 0.3.6.0 Build-type: Custom-License: BSD3+License: BSD-3-Clause License-file: LICENSE Copyright: (c) 2010-2018 Robin KAY Author: Robin KAY-Maintainer: komadori@gekkou.co.uk+Maintainer: saschaprolic@googlemail.com Stability: experimental Homepage: http://www.gekkou.co.uk/software/hsqml/ Category: Graphics, GUI Synopsis: Haskell binding for Qt Quick++tested-with: GHC ==9.4.8 || ==9.6.6+ Extra-source-files:- README CHANGELOG+ README.md cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs++Extra-doc-files:+ CHANGELOG+ Description: A Haskell binding for Qt Quick, a cross-platform framework for creating graphical user interfaces. For further information on installing and using this library, please see the project's web site. +Source-repository head+ type: git+ location: https://github.com/prolic/HsQML+ Flag UsePkgConfig Description: Use pkg-config for libraries instead of the platform default mechanism.@@ -48,18 +59,36 @@ Setup-depends: base == 4.*, template-haskell == 2.*,- Cabal >= 2.0 && < 2.1,- filepath >= 1.3 && < 1.5+ Cabal >= 3.0 && < 4.0,+ filepath >= 1.4.300 && < 1.5 +common extensions+ default-extensions:+ NoPolyKinds+ TypeOperators++ default-language: GHC2021++common ghc-options+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+ -fhide-source-paths -Wno-unused-do-bind -fshow-hole-constraints+ -Wno-unticked-promoted-constructors+ Library- Default-language: Haskell2010+ import: extensions+ import: ghc-options Build-depends: base == 4.*,- containers >= 0.4 && < 0.6,- filepath >= 1.3 && < 1.5,- text >= 0.11 && < 1.3,- tagged >= 0.4 && < 0.9,- transformers >= 0.2 && < 0.6+ bytestring >= 0.11.5 && < 0.12,+ containers >= 0.6.7 && < 0.7,+ directory >= 1.3.8 && < 1.4,+ filepath >= 1.4.300 && < 1.5,+ text >= 2.0.2 && < 2.1,+ tagged >= 0.8.9 && < 0.9,+ transformers >= 0.6.1 && < 0.7,+ QuickCheck >= 2.4 && < 2.16, Exposed-modules: Graphics.QML Graphics.QML.Debug@@ -84,7 +113,9 @@ C-sources: cbits/Canvas.cpp cbits/Class.cpp+ cbits/ClipboardHelper.cpp cbits/Engine.cpp+ cbits/HighDpiScaling.cpp cbits/Intrinsics.cpp cbits/Manager.cpp cbits/Model.cpp@@ -92,12 +123,14 @@ Include-dirs: cbits X-moc-headers: cbits/Canvas.h+ cbits/ClipboardHelper.h cbits/Engine.h+ cbits/HighDpiScaling.h cbits/Manager.h cbits/Model.h CC-options: --std=c++11 X-separate-cbits: True- Build-tools: c2hs+ build-tool-depends: c2hs:c2hs if flag(ForceGHCiLib) X-force-ghci-lib: True if flag(UseExitHook)@@ -107,39 +140,39 @@ if os(windows) && !flag(UsePkgConfig) Include-dirs: /QT_ROOT/include Extra-libraries:- Qt5Core, Qt5Gui, Qt5Widgets, Qt5Qml, Qt5Quick, stdc+++ Qt5Core, Qt5Gui, Qt5Widgets, Qt5Network, Qt5Qml, Qt5Quick, stdc++ Extra-lib-dirs: /SYS_ROOT/bin /QT_ROOT/bin if impl(ghc < 7.8) -- Pre-7.8 GHCi can't load eh_frame sections GHC-options: -optc-fno-asynchronous-unwind-tables else if os(darwin) && !flag(UsePkgConfig)- Frameworks: QtCore QtGui QtWidgets QtQml QtQuick+ Frameworks: QtCore QtGui QtWidgets QtNetwork QtQml QtQuick CC-options: -F /QT_ROOT/lib- GHC-options: -hide-option-framework-path /QT_ROOT/lib- GHC-shared-options: -hide-option-framework-path /QT_ROOT/lib- X-framework-dirs: /QT_ROOT/lib+ Extra-framework-dirs: /QT_ROOT/lib else Pkgconfig-depends: Qt5Core >= 5.0 && < 6.0, Qt5Gui >= 5.0 && < 6.0, Qt5Widgets >= 5.0 && < 6.0,+ Qt5Network >= 5.0 && < 6.0, Qt5Qml >= 5.0 && < 6.0, Qt5Quick >= 5.0 && < 6.0 Extra-libraries: stdc++ Test-Suite hsqml-test1+ import: extensions+ import: ghc-options Type: exitcode-stdio-1.0- Default-language: Haskell2010 Hs-source-dirs: test Main-is: Test1.hs Build-depends: base == 4.*,- containers >= 0.4 && < 0.6,- directory >= 1.1 && < 1.4,- text >= 0.11 && < 1.3,- tagged >= 0.4 && < 0.9,- QuickCheck >= 2.4 && < 2.12,+ containers >= 0.6.7 && < 0.7,+ directory >= 1.3.8 && < 1.4,+ text >= 2.0.2 && < 2.1,+ tagged >= 0.8.9 && < 0.9,+ QuickCheck >= 2.15 && < 2.16, hsqml Other-modules: Graphics.QML.Test.AutoListTest@@ -157,7 +190,3 @@ GHC-options: -hide-option-framework-path /QT_ROOT/lib if flag(ThreadedTestSuite) GHC-options: -threaded--Source-repository head- type: darcs- location: http://hub.darcs.net/komadori/HsQML/
src/Graphics/QML/Engine.hs view
@@ -12,7 +12,8 @@ initialDocument, contextObject, importPaths,- pluginPaths),+ pluginPaths,+ iconPath), defaultEngineConfig, Engine, runEngine,@@ -21,6 +22,7 @@ runEngineLoop, joinEngine, killEngine,+ enableHighDpiScaling, -- * Event Loop RunQML(),@@ -30,7 +32,8 @@ setQtArgs, getQtArgs, QtFlag(- QtShareOpenGLContexts),+ QtShareOpenGLContexts,+ QtEnableQMLDebug), setQtFlag, getQtFlag, shutdownQt,@@ -59,6 +62,8 @@ import Data.List import Data.Traversable (sequenceA) import Data.Typeable+import Foreign.C.String (CString, withCString)+import Foreign.C.Types (CChar) import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable@@ -74,9 +79,15 @@ -- | Additional search paths for QML modules importPaths :: [FilePath], -- | Additional search paths for QML native plugins- pluginPaths :: [FilePath]+ pluginPaths :: [FilePath],+ iconPath :: Maybe FilePath } +foreign import ccall "hsqml_set_window_icon" setWindowIcon :: Ptr CChar -> IO ()++foreign import ccall "hsqml_enable_high_dpi_scaling" enableHighDpiScaling :: IO ()++ -- | Default engine configuration. Loads @\"main.qml\"@ from the current -- working directory into a visible window with no context object. defaultEngineConfig :: EngineConfig@@ -84,7 +95,8 @@ initialDocument = DocumentPath "main.qml", contextObject = Nothing, importPaths = [],- pluginPaths = []+ pluginPaths = [],+ iconPath = Nothing } -- | Represents a QML engine.@@ -96,17 +108,24 @@ runEngineAsync config = RunQML $ do hsqmlInit finishVar <- newEmptyMVar+ let obj = contextObject config DocumentPath res = initialDocument config impPaths = importPaths config plugPaths = pluginPaths config stopCb = putMVar finishVar () + ctxHndl <- sequenceA $ fmap mToHndl obj engHndl <- mWithCVal (T.pack res) $ \resPtr -> withManyArray0 mWithCVal (map T.pack impPaths) nullPtr $ \impPtr -> withManyArray0 mWithCVal (map T.pack plugPaths) nullPtr $ \plugPtr -> hsqmlCreateEngine ctxHndl (HsQMLStringHandle $ castPtr resPtr) (castPtr impPtr) (castPtr plugPtr) stopCb++ case iconPath config of+ Just path -> liftIO $ withCString path setWindowIcon+ Nothing -> return ()+ return $ Engine engHndl finishVar withMany :: (a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c@@ -257,10 +276,12 @@ -- | Enables resource sharing between OpenGL contexts. This must be set in -- order to use QtWebEngine. = QtShareOpenGLContexts+ | QtEnableQMLDebug deriving Show internalFlag :: QtFlag -> HsQMLGlobalFlag internalFlag QtShareOpenGLContexts = HsqmlGflagShareOpenglContexts+internalFlag QtEnableQMLDebug = HsqmlGflagEnableQmlDebug -- | Sets or clears one of the application flags used by Qt and returns True -- if successful. If the flag or flag value is not supported then it will
src/Graphics/QML/Internal/Marshal.hs view
@@ -12,6 +12,7 @@ import Prelude hiding (catch) import Control.Exception (SomeException(SomeException), catch)+import Control.Monad (when) import Control.Monad.Trans.Maybe import Data.Maybe import Data.Tagged@@ -22,10 +23,11 @@ runErrIO :: ErrIO a -> IO () runErrIO m = do- r <- catch (runMaybeT m) $ \(SomeException _) -> return Nothing- if isNothing r- then hPutStrLn stderr "Warning: Marshalling error."- else return ()+ r <- catch (runMaybeT m) $ \(e :: SomeException) -> do+ hPutStrLn stderr $ "Warning: Marshalling error: " ++ show e+ return Nothing+ when (isNothing r) $+ hPutStrLn stderr "Warning: Marshalling error (see above for details)." errIO :: IO a -> ErrIO a errIO = MaybeT . fmap Just
src/Graphics/QML/Marshal.hs view
@@ -3,6 +3,7 @@ TypeFamilies, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Type classs and instances for marshalling values between Haskell and QML. module Graphics.QML.Marshal (@@ -49,12 +50,15 @@ import Control.Monad import Control.Monad.Trans.Maybe+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU import Data.Tagged import Data.Int import Data.Text (Text)-import qualified Data.Text.Foreign as T+import qualified Data.Text.Encoding as TE import Foreign.C.Types import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr import Foreign.Storable @@ -138,21 +142,24 @@ -- Text/QString built-in type -- + instance Marshal Text where type MarshalMode Text c d = ModeBidi c marshaller = Marshaller { mTypeCVal_ = Tagged tyString, mFromCVal_ = \ptr -> errIO $ do pair <- alloca (\bufPtr -> do- len <- hsqmlReadString (- HsQMLStringHandle $ castPtr ptr) bufPtr+ len <- hsqmlReadString (HsQMLStringHandle $ castPtr ptr) bufPtr buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- uncurry T.fromPtr pair,+ return (buf, len))+ let (buf, len) = pair+ bs <- BS.packCStringLen (castPtr buf, len * 2)+ return $ TE.decodeUtf16LE bs, mToCVal_ = \txt ptr -> do- array <- hsqmlWriteString- (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)- T.unsafeCopyToPtr txt (castPtr array),+ let bs = TE.encodeUtf16LE txt+ ucs2Length = BS.length bs `div` 2+ array <- hsqmlWriteString ucs2Length (HsQMLStringHandle $ castPtr ptr)+ BSU.unsafeUseAsCStringLen bs (\(bsp, bslen) -> copyBytes (castPtr array) bsp bslen), mWithCVal_ = \txt f -> withStrHndl $ \(HsQMLStringHandle ptr) -> do mToCVal txt $ castPtr ptr
src/Graphics/QML/Objects.hs view
@@ -245,7 +245,7 @@ in Tagged $ MethodTypeInfo [] typ mkUniformFunc :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,+ (Marshal tt, MethodSuffix ms) => (tt -> ms) -> UniformFunc mkUniformFunc f = \pt pv -> do@@ -263,9 +263,12 @@ instance (IsVoidIO b) => IsVoidIO (a -> b) instance IsVoidIO VoidIO -mkSpecialFunc :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,- MethodSuffix ms, IsVoidIO ms) => (tt -> ms) -> UniformFunc+mkSpecialFunc+ :: forall tt ms.+ ( Marshal tt+ , MethodSuffix ms)+ => (tt -> ms)+ -> UniformFunc mkSpecialFunc f = \pt pv -> do hndl <- hsqmlGetObjectFromPointer pt this <- mFromHndl hndl@@ -278,7 +281,7 @@ -- there may be zero or more parameter arguments followed by an optional return -- argument in the IO monad. defMethod :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, MethodSuffix ms) =>+ (Marshal tt, MethodSuffix ms) => String -> (tt -> ms) -> Member (GetObjType tt) defMethod name f = let crude = untag (mkMethodTypes :: Tagged ms MethodTypeInfo)@@ -341,7 +344,7 @@ -- 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,+ forall tt skv. (Marshal tt, SignalKeyValue skv) => skv -> tt -> SignalValueParams skv fireSignal key this = let start cnt = postJob $ do@@ -365,8 +368,8 @@ newtype SignalKey p = SignalKey Unique -- | Creates a new 'SignalKey'. -newSignalKey :: (SignalSuffix p) => IO (SignalKey p)-newSignalKey = fmap SignalKey $ newUnique+newSignalKey :: IO (SignalKey p)+newSignalKey = fmap SignalKey newUnique -- | Instances of the 'SignalKeyClass' class identify distinct signals by type. -- The associated 'SignalParams' type specifies the signal's signature.@@ -419,7 +422,7 @@ -- | 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,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes) => String -> (tt -> IO tr) -> Member (GetObjType tt) defPropertyConst name g = Member ConstPropertyMember@@ -433,7 +436,7 @@ -- | Defines a named read-only property using an accessor function in the IO -- monad. defPropertyRO :: forall tt tr.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes) => String -> (tt -> IO tr) -> Member (GetObjType tt) defPropertyRO name g = Member PropertyMember@@ -446,7 +449,7 @@ -- | Defines a named read-only property with an associated signal. defPropertySigRO :: forall tt tr skv.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, SignalKeyValue skv) => String -> skv -> (tt -> IO tr) -> Member (GetObjType tt) defPropertySigRO name key g = Member PropertyMember@@ -460,7 +463,7 @@ -- | Defines a named read-write property using a pair of accessor and mutator -- functions in the IO monad. defPropertyRW :: forall tt tr.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) => String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt) defPropertyRW name g s = Member PropertyMember@@ -473,7 +476,7 @@ -- | Defines a named read-write property with an associated signal. defPropertySigRW :: forall tt tr skv.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes, SignalKeyValue skv) => String -> skv -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt)