diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +# HsQML + +[![Tests](https://github.com/prolic/HsQML/workflows/Tests/badge.svg)](https://github.com/prolic/HsQML/actions?query=workflow%3ATests) +[![Build status](https://ci.appveyor.com/api/projects/status/github/prolic/HsQML?svg=true)](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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 = diff --git a/cbits/ClipboardHelper.cpp b/cbits/ClipboardHelper.cpp new file mode 100644 --- /dev/null +++ b/cbits/ClipboardHelper.cpp @@ -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); +} diff --git a/cbits/ClipboardHelper.h b/cbits/ClipboardHelper.h new file mode 100644 --- /dev/null +++ b/cbits/ClipboardHelper.h @@ -0,0 +1,16 @@ +#ifndef CLIPBOARDHELPER_H +#define CLIPBOARDHELPER_H + +#include +#include +#include + +class HsQMLClipboardHelper : public QObject { + Q_OBJECT +public: + explicit HsQMLClipboardHelper(QObject *parent = nullptr); + + Q_INVOKABLE void copyText(const QString &text); +}; + +#endif // CLIPBOARDHELPER_H diff --git a/cbits/HighDpiScaling.cpp b/cbits/HighDpiScaling.cpp new file mode 100644 --- /dev/null +++ b/cbits/HighDpiScaling.cpp @@ -0,0 +1,5 @@ +#include "QtGui/QGuiApplication" + +extern "C" void hsqml_enable_high_dpi_scaling() { + QGuiApplication::setAttribute(Qt::AA_EnableHighDpiScaling); +} diff --git a/cbits/HighDpiScaling.h b/cbits/HighDpiScaling.h new file mode 100644 --- /dev/null +++ b/cbits/HighDpiScaling.h @@ -0,0 +1,9 @@ +#ifdef __cplusplus +extern "C" { +#endif + +void hsqml_enable_high_dpi_scaling(); + +#ifdef __cplusplus +} +#endif diff --git a/cbits/Manager.cpp b/cbits/Manager.cpp --- a/cbits/Manager.cpp +++ b/cbits/Manager.cpp @@ -4,12 +4,19 @@ #include #include #include +#include +#include +#include +#include +#include +#include #ifdef Q_OS_MAC #include #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( "HsQML.Model", 1, 0, "AutoListModel"); + qmlRegisterType( + "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)); + } } diff --git a/cbits/Manager.h b/cbits/Manager.h --- a/cbits/Manager.h +++ b/cbits/Manager.h @@ -11,6 +11,7 @@ #include #include #include +#include #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 { diff --git a/cbits/Model.cpp b/cbits/Model.cpp --- a/cbits/Model.cpp +++ b/cbits/Model.cpp @@ -1,4 +1,5 @@ #include +#include #include "Model.h" #include "Manager.h" diff --git a/cbits/hsqml.h b/cbits/hsqml.h --- a/cbits/hsqml.h +++ b/cbits/hsqml.h @@ -198,6 +198,7 @@ typedef enum { HSQML_GFLAG_SHARE_OPENGL_CONTEXTS, + HSQML_GFLAG_ENABLE_QML_DEBUG, } HsQMLGlobalFlag; extern int hsqml_set_flag(HsQMLGlobalFlag, int); diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -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/ diff --git a/src/Graphics/QML/Engine.hs b/src/Graphics/QML/Engine.hs --- a/src/Graphics/QML/Engine.hs +++ b/src/Graphics/QML/Engine.hs @@ -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 diff --git a/src/Graphics/QML/Internal/Marshal.hs b/src/Graphics/QML/Internal/Marshal.hs --- a/src/Graphics/QML/Internal/Marshal.hs +++ b/src/Graphics/QML/Internal/Marshal.hs @@ -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 diff --git a/src/Graphics/QML/Marshal.hs b/src/Graphics/QML/Marshal.hs --- a/src/Graphics/QML/Marshal.hs +++ b/src/Graphics/QML/Marshal.hs @@ -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 diff --git a/src/Graphics/QML/Objects.hs b/src/Graphics/QML/Objects.hs --- a/src/Graphics/QML/Objects.hs +++ b/src/Graphics/QML/Objects.hs @@ -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)