diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,44 @@ HsQML - Release History +release-0.3.5.1 - 2018.03.28 + + * Fixed building with Semigroup/Monoid changes in base 4.11 (GHC 8.4.1). + * Fixed crash if setDebugLogLevel called before other functions. + * Fixed GHCi cbits library install location. + * Changed Setup script to use Cabal 2 API only. + * Relaxed Cabal constraint on 'QuickCheck'. + +release-0.3.5.0 - 2017.09.08 + + * Added facility for setting Qt application flags. + * Fixed building GHCi objects with Cabal 1.24. + * Relaxed Cabal constraint on 'QuickCheck' and fixed test suite. + * Relaxed Cabal constraint on 'directory'. + +release-0.3.4.1 - 2016.07.21 + + * Added support for Cabal 1.24 API. + * Fixed linking shared builds against MacOS frameworks (needs Cabal 1.24+). + * Fixed building with Qt 5.7. + +release-0.3.4.0 - 2016.02.24 + + * Added AutoListModel component. + * Added functions for joining and killing engines. + * Added functions to manipulate Qt's command-line arguments. + * Added exception handler to callbacks. + * Relaxed Cabal dependency constraint on 'filepath', 'tagged', 'transformers', + and 'QuickCheck'. + * Changed runEngineLoop to pass through command line arguments by default. + * Fixed class at same address as deleted class causing inaccessible objects. + * Fixed memory corruption bug prior to Qt 5.2 with workaround. + * Fixed building with Fedora-style moc executable names (non-qtselect). + * Fixed building GHCi objects with GHC 7.10. + * Fixed missing strong reference on engine context objects. + * Fixed missing include breaking compilation with Qt 5.0. + * Fixed switch compiler warnings. + * Fixed imports to support older GHCs. + release-0.3.3.0 - 2015.01.20 * Added support for Cabal 1.22 API. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright (c)2010-2015, Robin KAY +Copyright (c)2010-2018, Robin KAY +Copyright (c)2025, Sascha-Oliver Prolic All rights reserved. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,10 +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 -Issue Tracker: http://trac.gekkou.co.uk/hsqml/ diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# 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/ +**Original Darcs Repository (outdated):** http://hub.darcs.net/komadori/HsQML + +## Notes +- I made some changes, so this library works on newer GHC / cabal versions and has been tested on Qt5. +- This library has been tested with cabal 3.10.3.0, due to its custom Setup.hs, not all versions of cabal are supported. +- **Current Status:** This is a maintained fork of the original HsQML project. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,106 +1,44 @@ -#!/usr/bin/runhaskell -{-# LANGUAGE TemplateHaskell #-} +#!/usr/bin/runhaskell module Main where import Control.Monad import Data.Char import Data.List import Data.Maybe +import Data.String + +import qualified Distribution.InstalledPackageInfo as I +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription import Distribution.Simple -import Distribution.Simple.Compiler import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PreProcess 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 import Distribution.Verbosity -import qualified Distribution.InstalledPackageInfo as I -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import Language.Haskell.TH + import System.Environment -import qualified System.Info as Info import System.FilePath +import System.Info (os) --- Use Template Haskell to support different versions of the Cabal API -$(let - post4700BaseAPI = Info.compilerVersion >= Version [7,7] [] - post118CabalAPI = cabalVersion >= Version [1,17,0] [] - post122CabalAPI = cabalVersion >= Version [1,21,0] [] - vnameE = VarE . mkName - vnameP = VarP . mkName - cnameE = ConE . mkName - app2E f x y = AppE (AppE f x) y - app3E f x y z = AppE (app2E f x y) z - app4E f x y z u = AppE (app3E f x y z) u - app5E f x y z u v = AppE (app4E f x y z u) v - nothingE = cnameE "Nothing" - falseE = cnameE "False" - -- 'setEnv' function was added in base 4.7.0.0 - setEnvShim = if post4700BaseAPI - then vnameE "setEnv" - else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "()") - -- 'LocalBuildInfo' record changed fields in Cabal 1.18 - extractCLBI = if post118CabalAPI - then app2E (vnameE "getComponentLocalBuildInfo") - (vnameE "x") (cnameE "CLibName") - else AppE (vnameE "fromJust") $ AppE (vnameE "libraryConfig") - (vnameE "x") - -- 'programFindLocation' field changed signature in Cabal 1.18 - adaptFindLoc = if post118CabalAPI - then LamE [vnameP "f", vnameP "x", WildP] $ - AppE (vnameE "f") (vnameE "x") - else vnameE "id" - -- 'rawSystemStdInOut' function changed signature in Cabal 1.18 - rawSystemStdErr = if post118CabalAPI - then app4E (app3E (vnameE "rawSystemStdInOut") - (vnameE "v") (vnameE "p") (vnameE "a")) - nothingE nothingE nothingE falseE - else app5E (vnameE "rawSystemStdInOut") - (vnameE "v") (vnameE "p") (vnameE "a") nothingE falseE - -- 'programPostConf' field changed signature in Cabal 1.18 - noPostConf = if post118CabalAPI - then LamE [WildP, vnameP "c"] $ AppE (vnameE "return") (vnameE "c") - else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "[]") - -- 'generateRegistrationInfo' function changed signature in Cabal 1.22 - genRegInfo = if post122CabalAPI - then LamE [vnameP "pdb"] $ app2E (vnameE ">>=") - (AppE (vnameE "absolutePackageDBPaths") (vnameE "pdb")) $ - LamE [vnameP "apdb"] $ - app5E (app4E (vnameE "generateRegistrationInfo") - (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi")) - (vnameE "clbi") (vnameE "inp") - (AppE (vnameE "relocatable") (vnameE "lbi")) (vnameE "dir") - (AppE (vnameE "registrationPackageDB") (vnameE "apdb")) - else LamE [WildP] $ app3E (app4E (vnameE "generateRegistrationInfo") - (vnameE "verb") (vnameE "pkg") (vnameE "lib") (vnameE "lbi")) - (vnameE "clbi") (vnameE "inp") (vnameE "dir") - in return [ - FunD (mkName "setEnvShim") [ - Clause [] (NormalB setEnvShim) []], - FunD (mkName "extractCLBI") [ - Clause [vnameP "x"] (NormalB extractCLBI) []], - FunD (mkName "adaptFindLoc") [ - Clause [] (NormalB adaptFindLoc) []], - FunD (mkName "rawSystemStdErr") [ - Clause [vnameP "v", vnameP "p", vnameP "a"] ( - NormalB rawSystemStdErr) []], - FunD (mkName "noPostConf") [ - Clause [] (NormalB noPostConf) []], - FunD (mkName "genRegInfo") [ - Clause [vnameP "verb", vnameP "pkg", vnameP "lib", vnameP "lbi", - vnameP "clbi", vnameP "inp", vnameP "dir"] ( - NormalB genRegInfo) []]]) +import Text.Read (readMaybe) main :: IO () main = do -- If system uses qtchooser(1) then encourage it to choose Qt 5 env <- getEnvironment case lookup "QT_SELECT" env of - Nothing -> setEnvShim "QT_SELECT" "5" + Nothing -> setEnv "QT_SELECT" "5" _ -> return () -- Chain standard setup defaultMainWithHooks simpleUserHooks { @@ -118,13 +56,21 @@ getCustomFlag name pkgDesc = fromMaybe False . simpleParse $ getCustomStr name pkgDesc +xForceGHCiLib, xMocHeaders, xFrameworkDirs, xSeparateCbits :: String +xForceGHCiLib = "x-force-ghci-lib" +xMocHeaders = "x-moc-headers" +xFrameworkDirs = "x-framework-dirs" +xSeparateCbits = "x-separate-cbits" + confWithQt :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> IO LocalBuildInfo confWithQt (gpd,hbi) flags = do let verb = fromFlag $ configVerbosity flags - mocPath <- findProgramLocation verb "moc" - cppPath <- findProgramLocation verb "cpp" - let mapLibBI = fmap . mapCondTree . mapBI $ substPaths mocPath cppPath + mocPath <- (fmap . fmap) fst $ + programFindLocation mocProgram verb defaultProgramSearchPath + cppPath <- (fmap . fmap) fst $ + findProgramOnSearchPath verb defaultProgramSearchPath "cpp" + let mapLibBI = fmap $ mapCondTree (mapBI $ substPaths mocPath cppPath) id id gpd' = gpd { condLibrary = mapLibBI $ condLibrary gpd, condExecutables = mapAllBI mocPath cppPath $ condExecutables gpd, @@ -134,9 +80,9 @@ -- Find Qt moc program and store in database (_,_,db') <- requireProgramVersion verb mocProgram qtVersionRange (withPrograms lbi) - -- Force enable GHCi workaround library if flag set and not using shared libs + -- Force enable GHCi workaround library if flag set and not using shared libs let forceGHCiLib = - (getCustomFlag "x-force-ghci-lib" $ localPkgDescr lbi) && + (getCustomFlag xForceGHCiLib $ localPkgDescr lbi) && (not $ withSharedLib lbi) -- Update LocalBuildInfo return lbi {withPrograms = db', @@ -145,25 +91,34 @@ mapAllBI :: (HasBuildInfo a) => Maybe FilePath -> Maybe FilePath -> [(x, CondTree c v a)] -> [(x, CondTree c v a)] mapAllBI mocPath cppPath = - mapSnd . mapCondTree . mapBI $ substPaths mocPath cppPath + mapSnd $ mapCondTree (mapBI $ substPaths mocPath cppPath) id id -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) +-- 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 toRoot = takeDirectory . takeDirectory . fromMaybe "" - substPath = replace "/QT_ROOT" (toRoot mocPath) . - replace "/SYS_ROOT" (toRoot cppPath) - in build {ccOptions = map substPath $ ccOptions build, - ldOptions = map substPath $ ldOptions build, - extraLibDirs = map substPath $ extraLibDirs build, - includeDirs = map substPath $ includeDirs build, - options = mapSnd (map substPath) $ options build, - customFieldsBI = mapSnd substPath $ customFieldsBI build} + 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 () @@ -184,75 +139,88 @@ 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 + option name = words $ fromMaybe "" $ lookup name $ customFieldsBI build + incs = option xMocHeaders bDir = buildDir lbi cpps = map (\inc -> bDir (takeDirectory inc) ("moc_" ++ (takeBaseName inc) ++ ".cpp")) incs + args = map ("-I"++) (includeDirs build) ++ + map ("-F"++) (option xFrameworkDirs) + -- Run moc on each of the header files containing QObject subclasses 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} + runProgram verb moc $ [i,"-o",o] ++ args) $ zip incs cpps + -- Add the moc generated source files to be compiled + return build {cxxSources = cpps ++ cxxSources build, + cxxOptions = "-fPIC" : cxxOptions build} needsGHCiFix :: PackageDescription -> LocalBuildInfo -> Bool needsGHCiFix pkgDesc lbi = - withGHCiLib lbi && getCustomFlag "x-separate-cbits" pkgDesc + withGHCiLib lbi && getCustomFlag xSeparateCbits pkgDesc mkGHCiFixLibPkgId :: PackageDescription -> PackageIdentifier mkGHCiFixLibPkgId pkgDesc = let pid = packageId pkgDesc - (PackageName name) = pkgName pid - in pid {pkgName = PackageName $ "cbits-" ++ name} + 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 = do - let bDir = buildDir lbi - ms = map ModuleName.toFilePath $ libModules lib - hsObjs = map ((bDir ) . (<.> "o")) ms - stubObjs <- fmap catMaybes $ - mapM (findFileWithExtension ["o"] [bDir]) $ map (++ "_stub") ms - (ld,_) <- requireProgram verb ldProgram (withPrograms lbi) - combineObjectFiles verb ld - (bDir (("HS" ++) $ display $ packageId pkgDesc) <.> "o") - (stubObjs ++ hsObjs) - (ghc,_) <- requireProgram verb ghcProgram (withPrograms lbi) - let bi = libBuildInfo lib - runProgram verb ghc ( - ["-shared","-o",bDir (mkGHCiFixLibName pkgDesc)] ++ - (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) ++ - (map ("-L" ++) $ extraLibDirs bi) ++ - (map ((bDir ) . flip replaceExtension objExtension) $ cSources bi)) - return () +buildGHCiFix verb pkgDesc lbi lib = + let bDir = buildDir lbi + 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 $ + -- fromString is for compatibility between String (Cabal-3.10) + -- and Suffix (Cabal-3.12) + mapM (findFileWithExtension [fromString "o"] [bDir]) $ map (++ "_stub") ms + 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 platform)] ++ + (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) ++ + (map ("-L" ++) $ extraLibDirs bi) ++ + (map ((bDir ) . flip replaceExtension objExtension) $ cxxSources bi)) + return () mocProgram :: Program mocProgram = Program { programName = "moc", - programFindLocation = adaptFindLoc $ - \verb -> findProgramLocation verb "moc", + programFindLocation = \verb search -> + fmap msum $ mapM (findProgramOnSearchPath verb search) ["moc-qt5", "moc"], programFindVersion = \verb path -> do - (oLine,eLine,_) <- rawSystemStdErr verb path ["-v"] - return $ - (findSubseq (stripPrefix "(Qt ") eLine `mplus` - findSubseq (stripPrefix "moc ") oLine) >>= - simpleParse . takeWhile (\c -> isDigit c || c == '.'), - programPostConf = noPostConf + (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 qtVersionRange = intersectVersionRanges - (orLaterVersion $ Version [5,0] []) (earlierVersion $ Version [6,0] []) + (orLaterVersion $ mkVersion [5,0]) (earlierVersion $ mkVersion [6,0]) copyWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () @@ -261,39 +229,48 @@ 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) + instDirs = absoluteInstallDirs pkgDesc lbi dest + 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 + installOrdinaryFile verb (bDir file) (libdir instDirs file) -regWithQt :: +regWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () regWithQt pkg@PackageDescription { library = Just lib } lbi _ flags = do let verb = fromFlag $ regVerbosity flags inplace = fromFlag $ regInPlace flags dist = fromFlag $ regDistPref flags + reloc = relocatable lbi pkgDb = withPackageDB lbi - clbi = extractCLBI lbi - instPkgInfo <- genRegInfo verb pkg lib lbi clbi inplace dist pkgDb - let instPkgInfo' = instPkgInfo { - -- Add extra library for GHCi workaround - I.extraGHCiLibraries = - (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg] else []) ++ - I.extraGHCiLibraries instPkgInfo, - -- Add directories to framework search path - I.frameworkDirs = - words (getCustomStr "x-framework-dirs" pkg) ++ - I.frameworkDirs instPkgInfo} - case flagToMaybe $ regGenPkgConf flags of - Just regFile -> do - writeUTF8File (fromMaybe (display (packageId pkg) <.> "conf") regFile) $ - I.showInstalledPackageInfo instPkgInfo' - _ | fromFlag (regGenScript flags) -> - die "Registration scripts are not implemented." - | otherwise -> - registerPackage verb instPkgInfo' pkg lbi inplace pkgDb + clbis = componentNameCLBIs lbi (CLibName $ libName lib) + regDb <- fmap registrationPackageDB $ absolutePackageDBPaths pkgDb + flip mapM_ clbis $ \clbi -> do + instPkgInfo <- + generateRegistrationInfo verb pkg lib lbi clbi inplace reloc dist regDb + let instPkgInfo' = instPkgInfo { + -- Add extra library for GHCi workaround + I.extraGHCiLibraries = + (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg (hostPlatform lbi)] else []) ++ + I.extraGHCiLibraries instPkgInfo, + -- Add directories to framework search path + I.frameworkDirs = + words (getCustomStr xFrameworkDirs pkg) ++ + I.frameworkDirs instPkgInfo} + case flagToMaybe $ regGenPkgConf flags of + Just regFile -> do + writeUTF8File (fromMaybe (display (packageId pkg) <.> "conf") regFile) $ + I.showInstalledPackageInfo instPkgInfo' + _ | fromFlag (regGenScript flags) -> + die' verb "Registration scripts are not implemented." + | otherwise -> + let comp = compiler lbi + progs = withPrograms lbi + opts = defaultRegisterOptions + in registerPackage verb comp progs pkgDb instPkgInfo' opts regWithQt pkgDesc _ _ flags = - setupMessage (fromFlag $ regVerbosity flags) + setupMessage (fromFlag $ regVerbosity flags) "Package contains no library to register:" (packageId pkgDesc) instWithQt :: @@ -316,16 +293,16 @@ mapBI :: (BuildInfo -> BuildInfo) -> a -> a instance HasBuildInfo Library where - mapBI f x = x {libBuildInfo = f $ libBuildInfo x} + mapBI f x = x {libBuildInfo = f $ libBuildInfo x} instance HasBuildInfo Executable where - mapBI f x = x {buildInfo = f $ buildInfo x} + mapBI f x = x {buildInfo = f $ buildInfo x} instance HasBuildInfo TestSuite where - mapBI f x = x {testBuildInfo = f $ testBuildInfo x} + mapBI f x = x {testBuildInfo = f $ testBuildInfo x} instance HasBuildInfo Benchmark where - mapBI f x = x {benchmarkBuildInfo = f $ benchmarkBuildInfo x} + mapBI f x = x {benchmarkBuildInfo = f $ benchmarkBuildInfo x} maybeMapM :: (Monad m) => (a -> m b) -> (Maybe a) -> m (Maybe b) maybeMapM f = maybe (return Nothing) $ liftM Just . f diff --git a/SetupNoTH.hs b/SetupNoTH.hs deleted file mode 100644 --- a/SetupNoTH.hs +++ /dev/null @@ -1,294 +0,0 @@ -#!/usr/bin/runhaskell --- This is an alternate version of Setup.hs which doesn't use Template Haskell. --- It's appropriate for Cabal >= 1.18 && < 1.22 -module Main where - -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import Distribution.Simple -import Distribution.Simple.BuildPaths -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.Program -import Distribution.Simple.Program.Ld -import Distribution.Simple.Register -import Distribution.Simple.Setup -import Distribution.Simple.Utils -import Distribution.Text -import Distribution.Verbosity -import qualified Distribution.InstalledPackageInfo as I -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription -import System.Environment -import System.FilePath - --- 'setEnv' function was added in base 4.7.0.0 -setEnvShim :: String -> String -> IO () -setEnvShim _ _ = return () --- 'LocalBuildInfo' record changed fields in Cabal 1.18 -extractCLBI :: LocalBuildInfo -> ComponentLocalBuildInfo -extractCLBI x = getComponentLocalBuildInfo x CLibName --- 'programFindLocation' field changed signature in Cabal 1.18 -adaptFindLoc :: (Verbosity -> a) -> Verbosity -> ProgramSearchPath -> a -adaptFindLoc f x _ = f x --- 'rawSystemStdInOut' function changed signature in Cabal 1.18 -rawSystemStdErr v p a = rawSystemStdInOut v p a Nothing Nothing Nothing False --- 'programPostConf' field changed signature in Cabal 1.18 -noPostConf _ c = return c --- 'generateRegistrationInfo' function will change signature in Cabal 1.22 -genRegInfo verb pkg lib lbi clbi inp dir _ = - generateRegistrationInfo verb pkg lib lbi clbi inp dir - -main :: IO () -main = do - -- If system uses qtchooser(1) then encourage it to choose Qt 5 - env <- getEnvironment - case lookup "QT_SELECT" env of - Nothing -> setEnvShim "QT_SELECT" "5" - _ -> return () - -- Chain standard setup - defaultMainWithHooks simpleUserHooks { - confHook = confWithQt, buildHook = buildWithQt, - copyHook = copyWithQt, instHook = instWithQt, - regHook = regWithQt} - -getCustomStr :: String -> PackageDescription -> String -getCustomStr name pkgDesc = - fromMaybe "" $ do - lib <- library pkgDesc - lookup name $ customFieldsBI $ libBuildInfo lib - -getCustomFlag :: String -> PackageDescription -> Bool -getCustomFlag name pkgDesc = - fromMaybe False . simpleParse $ getCustomStr name pkgDesc - -confWithQt :: (GenericPackageDescription, HookedBuildInfo) -> ConfigFlags -> - IO LocalBuildInfo -confWithQt (gpd,hbi) flags = do - let verb = fromFlag $ configVerbosity flags - mocPath <- findProgramLocation verb "moc" - cppPath <- findProgramLocation verb "cpp" - let mapLibBI = fmap . mapCondTree . mapBI $ substPaths mocPath cppPath - gpd' = gpd { - condLibrary = mapLibBI $ condLibrary gpd, - condExecutables = mapAllBI mocPath cppPath $ condExecutables gpd, - condTestSuites = mapAllBI mocPath cppPath $ condTestSuites gpd, - condBenchmarks = mapAllBI mocPath cppPath $ condBenchmarks gpd} - lbi <- confHook simpleUserHooks (gpd',hbi) flags - -- Find Qt moc program and store in database - (_,_,db') <- requireProgramVersion verb - mocProgram qtVersionRange (withPrograms lbi) - -- Force enable GHCi workaround library if flag set and not using shared libs - let forceGHCiLib = - (getCustomFlag "x-force-ghci-lib" $ localPkgDescr lbi) && - (not $ withSharedLib lbi) - -- Update LocalBuildInfo - return lbi {withPrograms = db', - withGHCiLib = withGHCiLib lbi || forceGHCiLib} - -mapAllBI :: (HasBuildInfo a) => Maybe FilePath -> Maybe FilePath -> - [(x, CondTree c v a)] -> [(x, CondTree c v a)] -mapAllBI mocPath cppPath = - mapSnd . mapCondTree . mapBI $ substPaths mocPath cppPath - -mapCondTree :: (a -> a) -> CondTree v c a -> CondTree v c a -mapCondTree f (CondNode val cnstr cs) = - CondNode (f val) cnstr $ map updateChildren cs - where updateChildren (cond,left,right) = - (cond, mapCondTree f left, fmap (mapCondTree f) right) - -substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo -substPaths mocPath cppPath build = - let toRoot = takeDirectory . takeDirectory . fromMaybe "" - substPath = replace "/QT_ROOT" (toRoot mocPath) . - replace "/SYS_ROOT" (toRoot cppPath) - in build {ccOptions = map substPath $ ccOptions build, - ldOptions = map substPath $ ldOptions build, - extraLibDirs = map substPath $ extraLibDirs build, - includeDirs = map substPath $ includeDirs build, - options = mapSnd (map substPath) $ options build, - customFieldsBI = mapSnd substPath $ customFieldsBI build} - -buildWithQt :: - PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO () -buildWithQt pkgDesc lbi hooks flags = do - let verb = fromFlag $ buildVerbosity flags - libs' <- maybeMapM (\lib -> fmap (\lib' -> - lib {libBuildInfo = lib'}) $ fixQtBuild verb lbi $ libBuildInfo lib) $ - library pkgDesc - let pkgDesc' = pkgDesc {library = libs'} - lbi' = if (needsGHCiFix pkgDesc lbi) - then lbi {withGHCiLib = False, splitObjs = False} else lbi - buildHook simpleUserHooks pkgDesc' lbi' hooks flags - case libs' of - Just lib -> when (needsGHCiFix pkgDesc lbi) $ - buildGHCiFix verb pkgDesc lbi lib - Nothing -> return () - -fixQtBuild :: Verbosity -> LocalBuildInfo -> BuildInfo -> IO BuildInfo -fixQtBuild verb lbi build = do - let moc = fromJust $ lookupProgram mocProgram $ withPrograms lbi - incs = words $ fromMaybe "" $ lookup "x-moc-headers" $ - customFieldsBI build - bDir = buildDir lbi - cpps = map (\inc -> - bDir (takeDirectory inc) - ("moc_" ++ (takeBaseName inc) ++ ".cpp")) incs - mapM_ (\(i,o) -> do - createDirectoryIfMissingVerbose verb True (takeDirectory o) - runProgram verb moc [i,"-o",o]) $ zip incs cpps - return build {cSources = cpps ++ cSources build, - ccOptions = "-fPIC" : ccOptions build} - -needsGHCiFix :: PackageDescription -> LocalBuildInfo -> Bool -needsGHCiFix pkgDesc lbi = - withGHCiLib lbi && getCustomFlag "x-separate-cbits" pkgDesc - -mkGHCiFixLibPkgId :: PackageDescription -> PackageIdentifier -mkGHCiFixLibPkgId pkgDesc = - let pid = packageId pkgDesc - (PackageName name) = pkgName pid - in pid {pkgName = PackageName $ "cbits-" ++ name} - -mkGHCiFixLibName :: PackageDescription -> String -mkGHCiFixLibName pkgDesc = - ("lib" ++ display (mkGHCiFixLibPkgId pkgDesc)) <.> dllExtension - -mkGHCiFixLibRefName :: PackageDescription -> String -mkGHCiFixLibRefName pkgDesc = - prefix ++ display (mkGHCiFixLibPkgId pkgDesc) - where prefix = if dllExtension == "dll" then "lib" else "" - -buildGHCiFix :: - Verbosity -> PackageDescription -> LocalBuildInfo -> Library -> IO () -buildGHCiFix verb pkgDesc lbi lib = do - let bDir = buildDir lbi - ms = map ModuleName.toFilePath $ libModules lib - hsObjs = map ((bDir ) . (<.> "o")) ms - stubObjs <- fmap catMaybes $ - mapM (findFileWithExtension ["o"] [bDir]) $ map (++ "_stub") ms - (ld,_) <- requireProgram verb ldProgram (withPrograms lbi) - combineObjectFiles verb ld - (bDir (("HS" ++) $ display $ packageId pkgDesc) <.> "o") - (stubObjs ++ hsObjs) - (ghc,_) <- requireProgram verb ghcProgram (withPrograms lbi) - let bi = libBuildInfo lib - runProgram verb ghc ( - ["-shared","-o",bDir (mkGHCiFixLibName pkgDesc)] ++ - (ldOptions bi) ++ (map ("-l" ++) $ extraLibs bi) ++ - (map ("-L" ++) $ extraLibDirs bi) ++ - (map ((bDir ) . flip replaceExtension objExtension) $ cSources bi)) - return () - -mocProgram :: Program -mocProgram = Program { - programName = "moc", - programFindLocation = adaptFindLoc $ - \verb -> findProgramLocation verb "moc", - programFindVersion = \verb path -> do - (oLine,eLine,_) <- rawSystemStdErr verb path ["-v"] - return $ - (findSubseq (stripPrefix "(Qt ") eLine `mplus` - findSubseq (stripPrefix "moc ") oLine) >>= - simpleParse . takeWhile (\c -> isDigit c || c == '.'), - programPostConf = noPostConf -} - -qtVersionRange :: VersionRange -qtVersionRange = intersectVersionRanges - (orLaterVersion $ Version [5,0] []) (earlierVersion $ Version [6,0] []) - -copyWithQt :: - PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () -copyWithQt pkgDesc lbi hooks flags = do - copyHook simpleUserHooks pkgDesc lbi hooks flags - let verb = fromFlag $ copyVerbosity flags - dest = fromFlag $ copyDest flags - bDir = buildDir lbi - libDir = libdir $ absoluteInstallDirs pkgDesc lbi dest - file = mkGHCiFixLibName pkgDesc - when (needsGHCiFix pkgDesc lbi) $ - installOrdinaryFile verb (bDir file) (libDir file) - -regWithQt :: - PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO () -regWithQt pkg@PackageDescription { library = Just lib } lbi _ flags = do - let verb = fromFlag $ regVerbosity flags - inplace = fromFlag $ regInPlace flags - dist = fromFlag $ regDistPref flags - pkgDb = withPackageDB lbi - clbi = extractCLBI lbi - instPkgInfo <- genRegInfo verb pkg lib lbi clbi inplace dist pkgDb - let instPkgInfo' = instPkgInfo { - -- Add extra library for GHCi workaround - I.extraGHCiLibraries = - (if needsGHCiFix pkg lbi then [mkGHCiFixLibRefName pkg] else []) ++ - I.extraGHCiLibraries instPkgInfo, - -- Add directories to framework search path - I.frameworkDirs = - words (getCustomStr "x-framework-dirs" pkg) ++ - I.frameworkDirs instPkgInfo} - case flagToMaybe $ regGenPkgConf flags of - Just regFile -> do - writeUTF8File (fromMaybe (display (packageId pkg) <.> "conf") regFile) $ - I.showInstalledPackageInfo instPkgInfo' - _ | fromFlag (regGenScript flags) -> - die "Registration scripts are not implemented." - | otherwise -> - registerPackage verb instPkgInfo' pkg lbi inplace pkgDb -regWithQt pkgDesc _ _ flags = - setupMessage (fromFlag $ regVerbosity flags) - "Package contains no library to register:" (packageId pkgDesc) - -instWithQt :: - PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () -instWithQt pkgDesc lbi hooks flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyVerbosity = installVerbosity flags - } - regFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - copyWithQt pkgDesc lbi hooks copyFlags - when (hasLibs pkgDesc) $ regWithQt pkgDesc lbi hooks regFlags - -class HasBuildInfo a where - mapBI :: (BuildInfo -> BuildInfo) -> a -> a - -instance HasBuildInfo Library where - mapBI f x = x {libBuildInfo = f $ libBuildInfo x} - -instance HasBuildInfo Executable where - mapBI f x = x {buildInfo = f $ buildInfo x} - -instance HasBuildInfo TestSuite where - mapBI f x = x {testBuildInfo = f $ testBuildInfo x} - -instance HasBuildInfo Benchmark where - mapBI f x = x {benchmarkBuildInfo = f $ benchmarkBuildInfo x} - -maybeMapM :: (Monad m) => (a -> m b) -> (Maybe a) -> m (Maybe b) -maybeMapM f = maybe (return Nothing) $ liftM Just . f - -mapSnd :: (a -> a) -> [(x, a)] -> [(x, a)] -mapSnd f = map (\(x,y) -> (x,f y)) - -findSubseq :: ([a] -> Maybe b) -> [a] -> Maybe b -findSubseq f [] = f [] -findSubseq f xs@(_:ys) = - case f xs of - Nothing -> findSubseq f ys - Just r -> Just r - -replace :: (Eq a) => [a] -> [a] -> [a] -> [a] -replace [] _ xs = xs -replace _ _ [] = [] -replace src dst xs@(x:xs') = - case stripPrefix src xs of - Just xs'' -> dst ++ replace src dst xs'' - Nothing -> x : replace src dst xs' diff --git a/cbits/Canvas.cpp b/cbits/Canvas.cpp --- a/cbits/Canvas.cpp +++ b/cbits/Canvas.cpp @@ -1,4 +1,5 @@ #include "Canvas.h" +#include "Engine.h" #include "Manager.h" #include diff --git a/cbits/Class.cpp b/cbits/Class.cpp --- a/cbits/Class.cpp +++ b/cbits/Class.cpp @@ -43,7 +43,8 @@ int offset = arrayOff-(i*sizeof(QByteArrayData))+start; QByteArrayData data = { Q_REFCOUNT_INITIALIZE_STATIC, size-1, 0, 0, offset}; - new(&mMetaStrData[i*sizeof(QByteArrayData)]) QByteArrayData(data); + std::memcpy(&mMetaStrData[i*sizeof(QByteArrayData)], + &data, sizeof(QByteArrayData)); } std::memcpy(&mMetaStrData[arrayOff], metaStrChar, strLength); @@ -63,22 +64,7 @@ } HsQMLClass::~HsQMLClass() -{ - for (int i=0; ifreeFun((HsFunPtr)mMethods[i]); - } - for (unsigned int i=0; i<2*mPropertyCount; i++) { - if (mProperties[i]) { - gManager->freeFun((HsFunPtr)mProperties[i]); - } - } - gManager->freeStable(mHsTypeRep); - std::free(mMetaData); - std::free(mMethods); - std::free(mProperties); - - gManager->updateCounter(HsQMLManager::ClassCount, -1); -} +{} const char* HsQMLClass::name() { @@ -133,8 +119,37 @@ count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count)); if (count == 1) { - delete this; + destroy(); } +} + +void HsQMLClass::destroy() +{ + for (int i=0; ifreeFun((HsFunPtr)mMethods[i]); + mMethods[i] = NULL; + } + for (unsigned int i=0; i<2*mPropertyCount; i++) { + if (mProperties[i]) { + gManager->freeFun((HsFunPtr)mProperties[i]); + mProperties[i] = NULL; + } + } + gManager->freeStable(mHsTypeRep); + mHsTypeRep = NULL; + std::free(mMetaData); + mMetaData = NULL; + std::free(mMethods); + mMethods = NULL; + std::free(mProperties); + mProperties = NULL; + + gManager->updateCounter(HsQMLManager::ClassCount, -1); + + // Qt internally retains pointers to QMetaObjects it has encountered + // without any mechanism for unregistering them. Hence, classes can't be + // deleted prior to shutdown. + gManager->zombifyClass(this); } extern "C" int hsqml_get_next_class_id() diff --git a/cbits/Class.h b/cbits/Class.h --- a/cbits/Class.h +++ b/cbits/Class.h @@ -21,6 +21,7 @@ const HsQMLUniformFunc* methods(); const HsQMLUniformFunc* properties(); const QMetaObject* metaObj(); + void destroy(); enum RefSrc {Handle, ObjProxy}; void ref(RefSrc); void deref(RefSrc); 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/Engine.cpp b/cbits/Engine.cpp --- a/cbits/Engine.cpp +++ b/cbits/Engine.cpp @@ -5,10 +5,98 @@ #include "Engine.h" #include "Object.h" -HsQMLEngine::HsQMLEngine(const HsQMLEngineConfig& config) - : mComponent(&mEngine) - , mStopCb(config.stopCb) +static const char* cRefSrcNames[] = { + "Hndl", "Eng", "Event" +}; + +HsQMLEngineProxy::HsQMLEngineProxy() + : mEngine(NULL) + , mDead(false) + , mSerial(gManager->updateCounter(HsQMLManager::EngineSerial, 1)) + , mRefCount(0) { + ref(Handle); + gManager->updateCounter(HsQMLManager::EngineCount, 1); +} + +HsQMLEngineProxy::~HsQMLEngineProxy() +{ + gManager->updateCounter(HsQMLManager::EngineCount, -1); +} + +void HsQMLEngineProxy::setEngine(HsQMLEngine* engine) +{ + mEngine = engine; +} + +HsQMLEngine* HsQMLEngineProxy::engine() const +{ + return mEngine; +} + +void HsQMLEngineProxy::kill() +{ + mDead = true; + delete mEngine; + Q_ASSERT (!mEngine); +} + +bool HsQMLEngineProxy::dead() const +{ + return mDead; +} + +void HsQMLEngineProxy::ref(RefSrc src) +{ + int count = mRefCount.fetchAndAddOrdered(1); + + HSQML_LOG(count == 0 ? 3 : 4, + QString().sprintf("%s EngineProxy, id=%d, src=%s, count=%d.", + count ? "Ref" : "New", mSerial, cRefSrcNames[src], count+1)); +} + +void HsQMLEngineProxy::deref(RefSrc src) +{ + int count = mRefCount.fetchAndAddOrdered(-1); + + HSQML_LOG(count == 0 ? 3 : 4, + QString().sprintf("%s EngineProxy, id=%d, src=%s, count=%d.", + count > 1 ? "Deref" : "Delete", mSerial, cRefSrcNames[src], count)); + + if (count == 1) { + delete this; + } +} + +HsQMLEngineCreateEvent::HsQMLEngineCreateEvent(HsQMLEngineProxy* proxy) + : QEvent(HsQMLManagerApp::CreateEngineEvent) + , mProxy(proxy) + , contextObject(NULL) + , stopCb(NULL) +{ + mProxy->ref(HsQMLEngineProxy::Event); +} + +HsQMLEngineProxy* HsQMLEngineCreateEvent::proxy() const +{ + return mProxy; +} + +HsQMLEngineCreateEvent::~HsQMLEngineCreateEvent() +{ + mProxy->deref(HsQMLEngineProxy::Event); +} + +HsQMLEngine::HsQMLEngine(const HsQMLEngineCreateEvent* config, QObject* parent) + : QObject(parent) + , mProxy(config->proxy()) + , mComponent(&mEngine) + , mStopCb(config->stopCb) +{ + // Setup life-cycle + mProxy->setEngine(this); + mProxy->ref(HsQMLEngineProxy::Engine); + // Connect signals QObject::connect( &mEngine, SIGNAL(quit()), @@ -18,20 +106,21 @@ this, SLOT(componentStatus(QQmlComponent::Status))); // Obtain, re-parent, and set QML global object - if (config.contextObject) { - QObject* ctx = config.contextObject->object(this); - mEngine.rootContext()->setContextObject(ctx); - mObjects << ctx; + if (config->contextObject) { + HsQMLObjectProxy* ctxProxy = config->contextObject; + ctxProxy->ref(HsQMLObjectProxy::Engine); + mGlobals << ctxProxy; + mEngine.rootContext()->setContextObject(ctxProxy->object(this)); } // Engine settings mEngine.setImportPathList( - QStringList(config.importPaths) << mEngine.importPathList()); + QStringList(config->importPaths) << mEngine.importPathList()); mEngine.setPluginPathList( - QStringList(config.pluginPaths) << mEngine.pluginPathList()); + QStringList(config->pluginPaths) << mEngine.pluginPathList()); // Load document - mComponent.loadUrl(QUrl(config.initialURL)); + mComponent.loadUrl(QUrl(config->initialURL)); } HsQMLEngine::~HsQMLEngine() @@ -40,8 +129,15 @@ mStopCb(); gManager->freeFun(reinterpret_cast(mStopCb)); - // Delete owned objects - qDeleteAll(mObjects); + // Release engine proxy and globals + mProxy->setEngine(NULL); + mProxy->deref(HsQMLEngineProxy::Engine); + Q_FOREACH(HsQMLObjectProxy* proxy, mGlobals) { + proxy->deref(HsQMLObjectProxy::Engine); + } + + // Delete other owned resources + qDeleteAll(mResources); } bool HsQMLEngine::eventFilter(QObject* obj, QEvent* ev) @@ -62,12 +158,15 @@ switch (status) { case QQmlComponent::Ready: { QObject* obj = mComponent.create(); - mObjects << obj; + // Freeing the object causes memory corruption prior to Qt 5.2 +#if QT_VERSION >= 0x050200 + mResources << obj; +#endif QQuickWindow* win = qobject_cast(obj); QQuickItem* item = qobject_cast(obj); if (item) { win = new QQuickWindow(); - mObjects << win; + mResources << win; item->setParentItem(win->contentItem()); int width = item->width(); int height = item->height(); @@ -95,27 +194,48 @@ } deleteLater(); break;} + default: break; } } -extern "C" void hsqml_create_engine( +extern "C" HsQMLEngineHandle* hsqml_create_engine( HsQMLObjectHandle* contextObject, HsQMLStringHandle* initialURL, HsQMLStringHandle** importPaths, HsQMLStringHandle** pluginPaths, HsQMLTrivialCb stopCb) { - HsQMLEngineConfig config; - config.contextObject = reinterpret_cast(contextObject); - config.initialURL = *reinterpret_cast(initialURL); + Q_ASSERT (gManager); + + HsQMLEngineProxy* proxy = new HsQMLEngineProxy(); + HsQMLEngineCreateEvent* config = new HsQMLEngineCreateEvent(proxy); + + config->contextObject = reinterpret_cast(contextObject); + config->initialURL = *reinterpret_cast(initialURL); for (QString** p = reinterpret_cast(importPaths); *p; p++) { - config.importPaths.push_back(**p); + config->importPaths.push_back(**p); } for (QString** p = reinterpret_cast(pluginPaths); *p; p++) { - config.pluginPaths.push_back(**p); + config->pluginPaths.push_back(**p); } - config.stopCb = stopCb; + config->stopCb = stopCb; - Q_ASSERT (gManager); - gManager->createEngine(config); + gManager->postAppEvent(config); + return reinterpret_cast(proxy); +} + +extern "C" void hsqml_kill_engine( + HsQMLEngineHandle* hndl) +{ + HsQMLEngineProxy* proxy = reinterpret_cast(hndl); + + Q_ASSERT(gManager->isEventThread()); + proxy->kill(); +} + +extern void hsqml_finalise_engine_handle( + HsQMLEngineHandle* hndl) +{ + HsQMLEngineProxy* proxy = (HsQMLEngineProxy*)hndl; + proxy->deref(HsQMLEngineProxy::Handle); } diff --git a/cbits/Engine.h b/cbits/Engine.h --- a/cbits/Engine.h +++ b/cbits/Engine.h @@ -1,8 +1,9 @@ #ifndef HSQML_ENGINE_H #define HSQML_ENGINE_H -#include +#include #include +#include #include #include #include @@ -10,21 +11,49 @@ #include "hsqml.h" +class HsQMLEngine; class HsQMLObjectProxy; class HsQMLWindow; -struct HsQMLEngineConfig +class HsQMLEngineProxy { - HsQMLEngineConfig() - : contextObject(NULL) - , stopCb(NULL) - {} +public: + HsQMLEngineProxy(); + ~HsQMLEngineProxy(); + void setEngine(HsQMLEngine*); + HsQMLEngine* engine() const; + void kill(); + bool dead() const; + enum RefSrc {Handle, Engine, Event}; + void ref(RefSrc); + void deref(RefSrc); + +private: + Q_DISABLE_COPY(HsQMLEngineProxy) + + HsQMLEngine* mEngine; + bool mDead; + int mSerial; + QAtomicInt mRefCount; +}; + +class HsQMLEngineCreateEvent : public QEvent +{ +public: + HsQMLEngineCreateEvent(HsQMLEngineProxy*); + HsQMLEngineProxy* proxy() const; + virtual ~HsQMLEngineCreateEvent(); + + // Config fields HsQMLObjectProxy* contextObject; QString initialURL; QStringList importPaths; QStringList pluginPaths; HsQMLTrivialCb stopCb; + +private: + HsQMLEngineProxy* mProxy; }; class HsQMLEngine : public QObject @@ -32,7 +61,7 @@ Q_OBJECT public: - HsQMLEngine(const HsQMLEngineConfig&); + HsQMLEngine(const HsQMLEngineCreateEvent*, QObject* = NULL); ~HsQMLEngine(); bool eventFilter(QObject*, QEvent*); QQmlEngine* declEngine(); @@ -41,9 +70,11 @@ Q_DISABLE_COPY(HsQMLEngine) Q_SLOT void componentStatus(QQmlComponent::Status); + HsQMLEngineProxy* mProxy; QQmlEngine mEngine; QQmlComponent mComponent; - QList mObjects; + QList mGlobals; + QList mResources; HsQMLTrivialCb mStopCb; }; 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/Intrinsics.cpp b/cbits/Intrinsics.cpp --- a/cbits/Intrinsics.cpp +++ b/cbits/Intrinsics.cpp @@ -3,6 +3,7 @@ #include #include "Manager.h" +#include "Engine.h" /* String */ extern "C" size_t hsqml_get_string_size() diff --git a/cbits/Manager.cpp b/cbits/Manager.cpp --- a/cbits/Manager.cpp +++ b/cbits/Manager.cpp @@ -4,12 +4,22 @@ #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" #include "Object.h" // Declarations for part of Qt's internal API @@ -23,9 +33,11 @@ "ClassCounter", "ObjectCounter", "QObjectCounter", + "EngineCounter", "VariantCounter", "ClassSerial", - "ObjectSerial" + "ObjectSerial", + "EngineSerial", }; // This definition overrides a symbol in the GHC RTS @@ -82,7 +94,11 @@ , mJobsCb(NULL) , mYieldCb(NULL) , mActiveEngine(NULL) + , mQmlDebugEnabled(false) { + // Set default Qt args + setArgs(QStringList("HsQML")); + // Get log level from environment const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL"); if (env) { @@ -129,6 +145,60 @@ mFreeStable(stablePtr); } +bool HsQMLManager::setArgs(const QStringList& args) +{ + if (mApp || mShutdown) { + return false; + } + + mArgs.clear(); + mArgs.reserve(args.size()); + mArgsPtrs.clear(); + mArgsPtrs.reserve(args.size()); + Q_FOREACH(const QString& arg, args) { + mArgs << arg.toLocal8Bit(); + mArgsPtrs << mArgs.last().data(); + } + return true; +} + +QVector& HsQMLManager::argsPtrs() +{ + return mArgsPtrs; +} + +bool HsQMLManager::setFlag(HsQMLGlobalFlag flag, bool value) +{ + if (mApp || mShutdown) { + return false; + } + + switch (flag) { +#if QT_VERSION >= 0x050400 + case HSQML_GFLAG_SHARE_OPENGL_CONTEXTS: + QCoreApplication::setAttribute(Qt::AA_ShareOpenGLContexts, value); + return true; +#endif + case HSQML_GFLAG_ENABLE_QML_DEBUG: + mQmlDebugEnabled = value; + return true; + } + return false; +} + +bool HsQMLManager::getFlag(HsQMLGlobalFlag flag) +{ + switch (flag) { +#if QT_VERSION >= 0x050400 + case HSQML_GFLAG_SHARE_OPENGL_CONTEXTS: + return QCoreApplication::testAttribute(Qt::AA_ShareOpenGLContexts); +#endif + case HSQML_GFLAG_ENABLE_QML_DEBUG: + return mQmlDebugEnabled; + } + return false; +} + void HsQMLManager::registerObject(const QObject* obj) { mObjectSet.insert(obj); @@ -309,13 +379,6 @@ } } -void HsQMLManager::createEngine(const HsQMLEngineConfig& config) -{ - Q_ASSERT (mApp); - QMetaObject::invokeMethod( - mApp, "createEngine", Q_ARG(HsQMLEngineConfig, config)); -} - void HsQMLManager::setActiveEngine(HsQMLEngine* engine) { Q_ASSERT(!mActiveEngine || !engine); @@ -327,11 +390,21 @@ return mActiveEngine; } -void HsQMLManager::postObjectEvent(HsQMLObjectEvent* ev) +void HsQMLManager::postAppEvent(QEvent* ev) { QCoreApplication::postEvent(mApp, ev); } +void HsQMLManager::zombifyClass(HsQMLClass* clazz) +{ + if (mApp) { + mZombieClasses << clazz; + } + else { + delete clazz; + } +} + HsQMLManager::EventLoopStatus HsQMLManager::shutdown() { QMutexLocker locker(&mLock); @@ -352,12 +425,38 @@ } HsQMLManagerApp::HsQMLManagerApp() - : mArgC(1) - , mArg0(0) - , mArgV(&mArg0) - , mHookedHandler(*gManager->mOriginalHandler) - , mApp(mArgC, &mArgV) + : mHookedHandler(*gManager->mOriginalHandler) + , mArgC(gManager->argsPtrs().size()) + , 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 @@ -366,14 +465,20 @@ QVariantPrivate::registerHandler(0, &mHookedHandler); // Register custom types - qRegisterMetaType("HsQMLEngineConfig"); qmlRegisterType("HsQML.Canvas", 1, 0, "HaskellCanvas"); qmlRegisterType( "HsQML.Canvas", 1, 0, "OpenGLContextControl"); + qmlRegisterType( + "HsQML.Model", 1, 0, "AutoListModel"); + qmlRegisterType( + "HsQML.Clipboard", 1, 0, "ClipboardHelper"); } HsQMLManagerApp::~HsQMLManagerApp() -{} +{ + qDeleteAll(gManager->mZombieClasses); + gManager->mZombieClasses.clear(); +} void HsQMLManagerApp::customEvent(QEvent* ev) { @@ -396,6 +501,17 @@ case HsQMLManagerApp::RemoveGCLockEvent: { static_cast(ev)->process(); break;} + case HsQMLManagerApp::CreateEngineEvent: { + HsQMLEngineCreateEvent* create = + static_cast(ev); + if (create->proxy()->dead()) { + create->stopCb(); + } + else { + new HsQMLEngine(create, this); + } + break;} + default: break; } } @@ -405,17 +521,26 @@ gManager->mYieldCb(); } -void HsQMLManagerApp::createEngine(HsQMLEngineConfig config) +int HsQMLManagerApp::exec() { - HsQMLEngine* engine = new HsQMLEngine(config); - engine->setParent(this); + return mApp.exec(); } -int HsQMLManagerApp::exec() +void HsQMLManagerApp::setWindowIcon(QIcon* icon) { - return mApp.exec(); + 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)) @@ -428,6 +553,41 @@ } } +extern "C" int hsqml_set_args( + HsQMLStringHandle** args) +{ + QStringList argsList; + for (QString** p = reinterpret_cast(args); *p; p++) { + argsList.push_back(**p); + } + return gManager->setArgs(argsList); +} + +extern "C" int hsqml_get_args_count() +{ + return gManager->argsPtrs().size(); +} + +extern "C" void hsqml_get_args(HsQMLStringHandle** args) +{ + int argc = gManager->argsPtrs().size(); + char** argv = gManager->argsPtrs().data(); + for (int i=0; i(args[i]); + *string = QString::fromLocal8Bit(argv[i]); + } +} + +extern "C" int hsqml_set_flag(HsQMLGlobalFlag flag, int value) +{ + return gManager->setFlag(flag, value); +} + +extern "C" int hsqml_get_flag(HsQMLGlobalFlag flag) +{ + return gManager->getFlag(flag); +} + extern "C" HsQMLEventLoopStatus hsqml_evloop_run( HsQMLTrivialCb startCb, HsQMLTrivialCb jobsCb, @@ -463,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 @@ -3,19 +3,23 @@ #include #include +#include #include #include #include +#include #include +#include #include +#include #include "hsqml.h" -#include "Engine.h" #define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg) class HsQMLManagerApp; -class HsQMLObjectEvent; +class HsQMLClass; +class HsQMLEngine; class HsQMLManager { @@ -25,8 +29,10 @@ ObjectCount, QObjectCount, VariantCount, + EngineCount, ClassSerial, ObjectSerial, + EngineSerial, TotalCounters }; @@ -39,6 +45,10 @@ int updateCounter(CounterId, int); void freeFun(HsFunPtr); void freeStable(HsStablePtr); + bool setArgs(const QStringList&); + QVector& argsPtrs(); + bool setFlag(HsQMLGlobalFlag, bool); + bool getFlag(HsQMLGlobalFlag); void registerObject(const QObject*); void unregisterObject(const QObject*); void hookedConstruct(QVariant::Private*, const void*); @@ -50,11 +60,12 @@ EventLoopStatus requireEventLoop(); void releaseEventLoop(); void notifyJobs(); - void createEngine(const HsQMLEngineConfig&); void setActiveEngine(HsQMLEngine*); HsQMLEngine* activeEngine(); - void postObjectEvent(HsQMLObjectEvent*); + void postAppEvent(QEvent*); + void zombifyClass(HsQMLClass*); EventLoopStatus shutdown(); + void setWindowIcon(const QString& iconPath); private: friend class HsQMLManagerApp; @@ -66,7 +77,10 @@ bool mAtExit; void (*mFreeFun)(HsFunPtr); void (*mFreeStable)(HsStablePtr); + QVector mArgs; + QVector mArgsPtrs; QSet mObjectSet; + QVector mZombieClasses; const QVariant::Handler* mOriginalHandler; HsQMLManagerApp* mApp; QMutex mLock; @@ -78,6 +92,7 @@ HsQMLTrivialCb mJobsCb; HsQMLTrivialCb mYieldCb; HsQMLEngine* mActiveEngine; + bool mQmlDebugEnabled; }; class HsQMLManagerApp : public QObject @@ -89,14 +104,15 @@ virtual ~HsQMLManagerApp(); virtual void customEvent(QEvent*); virtual void timerEvent(QTimerEvent*); - Q_SLOT void createEngine(HsQMLEngineConfig); + virtual void setWindowIcon(QIcon*); int exec(); enum CustomEventIndicies { StartedLoopEventIndex, StopLoopEventIndex, PendingJobsEventIndex, - RemoveGCLockEventIndex + RemoveGCLockEventIndex, + CreateEngineEventIndex, }; static const QEvent::Type StartedLoopEvent = @@ -107,14 +123,14 @@ static_cast(QEvent::User+PendingJobsEventIndex); static const QEvent::Type RemoveGCLockEvent = static_cast(QEvent::User+RemoveGCLockEventIndex); + static const QEvent::Type CreateEngineEvent = + static_cast(QEvent::User+CreateEngineEventIndex); private: Q_DISABLE_COPY(HsQMLManagerApp) - int mArgC; - char mArg0; - char* mArgV; QVariant::Handler mHookedHandler; + int mArgC; QApplication mApp; }; diff --git a/cbits/Model.cpp b/cbits/Model.cpp new file mode 100644 --- /dev/null +++ b/cbits/Model.cpp @@ -0,0 +1,340 @@ +#include +#include + +#include "Model.h" +#include "Manager.h" + +HsQMLAutoListModel::HsQMLAutoListModel(QObject* parent) + : QAbstractListModel(parent) + , mMode(ByReset) + , mEqualityTestValid(false) + , mKeyFunctionValid(false) + , mOldOffset(0) + , mDefer(false) + , mPending(false) +{ +} + +void HsQMLAutoListModel::classBegin() +{ + mDefer = true; +} + +void HsQMLAutoListModel::componentComplete() +{ + mDefer = false; + if (mPending) { + updateModel(); + } +} + +int HsQMLAutoListModel::rowCount(const QModelIndex&) const +{ + return fromOldIndex(mOldModel.size()); +} + +QVariant HsQMLAutoListModel::data(const QModelIndex& index, int) const +{ + int i = index.row(); + const Element& e = + i < mNewModel.size() ? mNewModel[i] : mOldModel[toOldIndex(i)]; + return e.mValue.toVariant(); +} + +QHash HsQMLAutoListModel::roleNames() const +{ + QHash roleNames; + roleNames.insert(Qt::UserRole, QByteArray("modelData")); + return roleNames; +} + +void HsQMLAutoListModel::setMode(Mode mode) +{ + mMode = mode; +} + +HsQMLAutoListModel::Mode HsQMLAutoListModel::mode() const +{ + return mMode; +} + +void HsQMLAutoListModel::setSource(const QJSValue& source) +{ + bool change = !mSource.strictlyEquals(source); + mSource = source; + if (change) { + sourceChanged(); + } + updateModel(); +} + +QJSValue HsQMLAutoListModel::source() const +{ + return mSource; +} + +void HsQMLAutoListModel::setEqualityTest(const QJSValue& equalityTest) +{ + mEqualityTest = equalityTest; + mEqualityTestValid = equalityTest.isCallable(); +} + +QJSValue HsQMLAutoListModel::equalityTest() const +{ + return mEqualityTest; +} + +void HsQMLAutoListModel::setKeyFunction(const QJSValue& keyFunction) +{ + mKeyFunction = keyFunction; + mKeyFunctionValid = keyFunction.isCallable(); + mRehash = true; +} + +QJSValue HsQMLAutoListModel::keyFunction() const +{ + return mKeyFunction; +} + +void HsQMLAutoListModel::updateModel() +{ + if (mDefer) { + mPending = true; + return; + } + + switch (mMode) { + case ByReset: + updateModelByReset(); break; + case ByIndex: + updateModelByIndex(); break; + case ByKey: + updateModelByKey(true); break; + case ByKeyNoReorder: + updateModelByKey(false); break; + } +} + +void HsQMLAutoListModel::updateModelByReset() +{ + int srcLen = sourceLength(); + + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByReset: Inserted %d elements.", srcLen)); + beginResetModel(); + mOldModel.clear(); + mOldModel.reserve(srcLen); + for (int i=0; i oldLen) { + mOldModel.reserve(srcLen); + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByIndex: Inserted %d extra elements at %d.", + srcLen - oldLen, oldLen)); + beginInsertRows(QModelIndex(), oldLen, srcLen-1); + for (int i=oldLen; i srcLen) { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByIndex: Removed %d excess elements at %d.", + oldLen - srcLen, srcLen)); + beginRemoveRows(QModelIndex(), srcLen, oldLen-1); + mOldModel.erase(mOldModel.begin()+srcLen, mOldModel.end()); + endRemoveRows(); + } + + // This mode doesn't maintain the hashes + mRehash = true; +} + +void HsQMLAutoListModel::updateModelByKey(bool reorder) +{ + int srcLen = sourceLength(); + + // Build a map of element key's highest indices in the new source + typedef QHash SrcDict; + SrcDict srcDict; + if (reorder) { + for (int i=0; i ModelDict; + ModelDict modelDict; + for (int idx = mOldModel.size()-1; idx >= 0; --idx) { + Element& e = mOldModel[idx]; + if (mRehash) { + e.mKey = keyFunction(e.mValue); + } + modelDict.insert(e.mKey, idx); + } + mRehash = false; + + // Rearrange and insert new elements + Q_ASSERT(!mNewModel.size() && !mOldOffset); + mNewModel.reserve(srcLen); + for (int i=0; i= mOldOffset); + Q_ASSERT(elemIdx < mOldModel.size()); + modelDict.erase(it); + + // Try removing elements before target + while (elemIdx > mOldOffset) { + const Element& nextElem = mOldModel[mOldOffset]; + + if (reorder) { + // Check if element will be used later + SrcDict::iterator srcIt = srcDict.find(nextElem.mKey); + if (srcIt != srcDict.end()) { + if (srcIt.value() >= i) { + // Old element is still needed by the new source + break; + } + } + } + + // Remove element + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Removed element at %d.", i)); + beginRemoveRows(QModelIndex(), i, i); + mOldOffset++; + endRemoveRows(); + modelDict.erase(modelDict.find(nextElem.mKey)); + } + + // Move target element earlier in list if needed + if (elemIdx > mOldOffset) { + Q_ASSERT(reorder); + int srcIdx = fromOldIndex(elemIdx); + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Moved element at %d to %d.", + srcIdx, i)); + beginMoveRows(QModelIndex(), srcIdx, srcIdx, QModelIndex(), i); + mNewModel.append(mOldModel[elemIdx]); + mOldModel.remove(elemIdx); + endMoveRows(); + + // Renumber remaining indices in the old model + for (ModelDict::iterator renumIt = modelDict.begin(); + renumIt != modelDict.end();) { + ModelDict::iterator currIt = renumIt++; + Q_ASSERT(currIt.value() >= mOldOffset); + if (currIt.value() > elemIdx) { + currIt.value()--; + } + } + } + else { + // Transfer element from old to new model + mNewModel.append(mOldModel[elemIdx]); + mOldOffset++; + } + + // Has value changed? + handleInequality(srcVal, mNewModel, i); + Q_ASSERT(mNewModel.size() == i+1); + } + else { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Inserted element at %d.", i)); + beginInsertRows(QModelIndex(), i, i); + mNewModel.append(Element(srcVal, srcKey)); + endInsertRows(); + } + } + + // Move element to the old model, removing any excess elements from the end + bool excess = mOldOffset < mOldModel.size(); + if (excess) { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Removed %d excess elements at %d.", + mOldModel.size() - mOldOffset, srcLen)); + beginRemoveRows(QModelIndex(), srcLen, rowCount(QModelIndex())-1); + } + mNewModel.swap(mOldModel); + mNewModel.clear(); + mOldOffset = 0; + if (excess) { + endRemoveRows(); + } +} + +int HsQMLAutoListModel::sourceLength() +{ + return mSource.property("length").toInt(); +} + +int HsQMLAutoListModel::toOldIndex(int i) const +{ + return i - mNewModel.size() + mOldOffset; +} + +int HsQMLAutoListModel::fromOldIndex(int i) const +{ + return i + mNewModel.size() - mOldOffset; +} + +void HsQMLAutoListModel::handleInequality( + const QJSValue& a, Model& model, int i) +{ + if (!equalityTest(a, model[i].mValue)) { + model[i].mValue = a; + QModelIndex idx = createIndex(i, 0); + dataChanged(idx, idx); + } +} + +bool HsQMLAutoListModel::equalityTest(const QJSValue& a, const QJSValue& b) +{ + if (mEqualityTestValid) { + QJSValueList args; + args.append(a); + args.append(b); + return mEqualityTest.call(args).toBool(); + } + else { + return a.equals(b); + } +} + +QString HsQMLAutoListModel::keyFunction(const QJSValue& a) +{ + if (mKeyFunctionValid) { + QJSValueList args; + args.append(a); + return mKeyFunction.call(args).toString(); + } + else { + return a.toString(); + } +} diff --git a/cbits/Model.h b/cbits/Model.h new file mode 100644 --- /dev/null +++ b/cbits/Model.h @@ -0,0 +1,85 @@ +#ifndef HSQML_MODEL_H +#define HSQML_MODEL_H + +#include +#include +#include +#include + +class HsQMLAutoListModel : public QAbstractListModel, public QQmlParserStatus +{ + Q_OBJECT + Q_INTERFACES(QQmlParserStatus) + Q_ENUMS(Mode) + Q_PROPERTY(Mode mode READ mode WRITE setMode) + Q_PROPERTY(QJSValue source READ source WRITE setSource NOTIFY sourceChanged) + Q_PROPERTY(QJSValue equalityTest READ equalityTest WRITE setEqualityTest) + Q_PROPERTY(QJSValue keyFunction READ keyFunction WRITE setKeyFunction) + +public: + enum Mode { + ByReset, + ByIndex, + ByKey, + ByKeyNoReorder + }; + + HsQMLAutoListModel(QObject* = NULL); + + int rowCount(const QModelIndex&) const; + QVariant data(const QModelIndex&, int) const; + QHash roleNames() const; + + Q_SIGNAL void sourceChanged(); + void classBegin(); + void componentComplete(); + void setMode(Mode); + Mode mode() const; + void setSource(const QJSValue&); + QJSValue source() const; + void setEqualityTest(const QJSValue&); + QJSValue equalityTest() const; + void setKeyFunction(const QJSValue&); + QJSValue keyFunction() const; + +private: + struct Element { + Element() {} + Element(const QJSValue& value) : mValue(value) {} + Element(const QJSValue& value, const QString& key) + : mValue(value), mKey(key) {} + QJSValue mValue; + QString mKey; + }; + typedef QVector Model; + + void updateModel(); + void updateModelByReset(); + void updateModelByIndex(); + void updateModelByKey(bool); + int sourceLength(); + int toOldIndex(int) const; + int fromOldIndex(int) const; + bool modeTest(const QJSValue&, const QString&, int, int); + void handleInequality(const QJSValue&, Model&, int); + bool equalityTest(const QJSValue&, const QJSValue&); + bool identityTest(const QJSValue&, const QJSValue&); + QString keyFunction(const QJSValue&); + + Mode mMode; + QJSValue mSource; + QJSValue mEqualityTest; + bool mEqualityTestValid; + QJSValue mIdentityTest; + bool mIdentityTestValid; + QJSValue mKeyFunction; + bool mKeyFunctionValid; + Model mOldModel; + Model mNewModel; + int mOldOffset; + bool mDefer; + bool mPending; + bool mRehash; +}; + +#endif //HSQML_MODEL_H diff --git a/cbits/Object.cpp b/cbits/Object.cpp --- a/cbits/Object.cpp +++ b/cbits/Object.cpp @@ -5,10 +5,20 @@ #include "Object.h" #include "Class.h" +#include "Engine.h" #include "Manager.h" -static const char* cRefSrcNames[] = {"Hndl", "Weak", "Obj", "Event", "Var"}; +static const char* cRefSrcNames[] = { + "Hndl", "Weak", "Eng", "Var", "Obj", "Event" +}; +static bool isStrongRef(HsQMLObjectProxy::RefSrc src) +{ + return src == HsQMLObjectProxy::Handle || + src == HsQMLObjectProxy::Engine || + src == HsQMLObjectProxy::Variant; +} + HsQMLObjectFinaliser::HsQMLObjectFinaliser(HsQMLObjFinaliserCb cb) : mFinaliseCb(cb) {} @@ -60,7 +70,7 @@ mObject = new HsQMLObject(this, engine); HSQML_LOG(5, - QString().sprintf("New QObject, class=%s, id=%d, qptr=%p.", + QString().asprintf("New QObject, class=%s, id=%d, qptr=%p.", mKlass->name(), mSerial, mObject)); } @@ -76,7 +86,7 @@ Q_ASSERT(gManager->isEventThread()); HSQML_LOG(5, - QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.", + QString().asprintf("Release QObject, class=%s, id=%d, qptr=%p.", mKlass->name(), mSerial, mObject)); mObject = NULL; @@ -87,11 +97,11 @@ { Q_ASSERT(gManager->isEventThread()); - if (mObject && mHndlCount.loadAcquire() > 0 && !mObject->isGCLocked()) { + if (mObject && mStrongCount.loadAcquire() > 0 && !mObject->isGCLocked()) { mObject->setGCLock(); HSQML_LOG(5, - QString().sprintf("Lock QObject, class=%s, id=%d, qptr=%p.", + QString().asprintf("Lock QObject, class=%s, id=%d, qptr=%p.", mKlass->name(), mSerial, mObject)); } } @@ -100,12 +110,12 @@ { Q_ASSERT(gManager->isEventThread()); - if (mObject && mHndlCount.loadAcquire() == 0) { + if (mObject && mStrongCount.loadAcquire() == 0) { if (mObject->isGCLocked()) { mObject->clearGCLock(); HSQML_LOG(5, - QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.", + QString().asprintf("Unlock QObject, class=%s, id=%d, qptr=%p.", mKlass->name(), mSerial, mObject)); } else { @@ -150,26 +160,26 @@ int count = mRefCount.fetchAndAddOrdered(1); HSQML_LOG(count == 0 ? 3 : 4, - QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.", + QString().asprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.", count ? "Ref" : "New", mKlass->name(), mSerial, cRefSrcNames[src], count+1)); - if (src == Handle || src == Variant) { - mHndlCount.fetchAndAddOrdered(1); + if (isStrongRef(src)) { + mStrongCount.fetchAndAddOrdered(1); } } void HsQMLObjectProxy::deref(RefSrc src) { // Remove JavaScript GC lock when there are no strong handles - if (src == Handle || src == Variant) { - int hndlCount = mHndlCount.fetchAndAddOrdered(-1); - if (hndlCount == 1 && mObject) { + if (isStrongRef(src)) { + int strongCount = mStrongCount.fetchAndAddOrdered(-1); + if (strongCount == 1 && mObject) { if (src == Handle) { // Handles can be dereferenced from any thread. The event will // remove the lock if there are still no handles by the time // it reaches the event loop. - gManager->postObjectEvent(new HsQMLObjectEvent(this)); + gManager->postAppEvent(new HsQMLObjectEvent(this)); } else { removeGCLock(); @@ -180,7 +190,7 @@ int count = mRefCount.fetchAndAddOrdered(-1); HSQML_LOG(count == 1 ? 3 : 4, - QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.", + QString().asprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.", count > 1 ? "Deref" : "Delete", mKlass->name(), mSerial, cRefSrcNames[src], count)); diff --git a/cbits/Object.h b/cbits/Object.h --- a/cbits/Object.h +++ b/cbits/Object.h @@ -45,7 +45,7 @@ void addFinaliser(const HsQMLObjectFinaliser::Ref&); void runFinalisers(); HsQMLEngine* engine() const; - enum RefSrc {Handle, WeakHandle, Object, Event, Variant}; + enum RefSrc {Handle, WeakHandle, Engine, Variant, Object, Event}; void ref(RefSrc); void deref(RefSrc); @@ -57,7 +57,7 @@ int mSerial; HsQMLObject* volatile mObject; QAtomicInt mRefCount; - QAtomicInt mHndlCount; + QAtomicInt mStrongCount; QMutex mFinaliseMutex; typedef QVarLengthArray Finalisers; Finalisers mFinalisers; diff --git a/cbits/hsqml.h b/cbits/hsqml.h --- a/cbits/hsqml.h +++ b/cbits/hsqml.h @@ -8,13 +8,11 @@ #include #include -/* Manager */ +/* Init */ extern void hsqml_init( void (*)(HsFunPtr), void (*)(HsStablePtr)); -extern void hsqml_set_debug_loglevel(int); - /* Event Loop */ typedef void (*HsQMLTrivialCb)(); @@ -191,13 +189,39 @@ extern void hsqml_object_add_finaliser( HsQMLObjectHandle*, HsQMLObjFinaliserHandle*); +/* Global */ +extern int hsqml_set_args(HsQMLStringHandle**); + +extern int hsqml_get_args_count(); + +extern void hsqml_get_args(HsQMLStringHandle**); + +typedef enum { + HSQML_GFLAG_SHARE_OPENGL_CONTEXTS, + HSQML_GFLAG_ENABLE_QML_DEBUG, +} HsQMLGlobalFlag; + +extern int hsqml_set_flag(HsQMLGlobalFlag, int); + +extern int hsqml_get_flag(HsQMLGlobalFlag); + +extern void hsqml_set_debug_loglevel(int); + /* Engine */ -extern void hsqml_create_engine( +typedef char HsQMLEngineHandle; + +extern HsQMLEngineHandle* hsqml_create_engine( HsQMLObjectHandle*, HsQMLStringHandle*, HsQMLStringHandle**, HsQMLStringHandle**, HsQMLTrivialCb stopCb); + +extern void hsqml_kill_engine( + HsQMLEngineHandle*); + +extern void hsqml_finalise_engine_handle( + HsQMLEngineHandle*); /* Canvas */ typedef char HsQMLGLDelegateHandle; diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -1,25 +1,35 @@ +cabal-version: 3.8 Name: hsqml -Version: 0.3.3.0 -Cabal-version: >= 1.14 +Version: 0.3.7.0 Build-type: Custom -License: BSD3 +License: BSD-3-Clause License-file: LICENSE -Copyright: (c) 2010-2015 Robin KAY -Author: Robin KAY -Maintainer: komadori@gekkou.co.uk +Copyright: (c) 2010-2018 Robin KAY, (c) 2025 Sascha-Oliver Prolic +Author: Robin KAY, Sascha-Oliver Prolic +Maintainer: saschaprolic@googlemail.com Stability: experimental Homepage: http://www.gekkou.co.uk/software/hsqml/ -Bug-reports: http://trac.gekkou.co.uk/hsqml/ Category: Graphics, GUI Synopsis: Haskell binding for Qt Quick + +tested-with: GHC ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.2 || ==9.12.2 + Extra-source-files: - README CHANGELOG SetupNoTH.hs + 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. @@ -40,21 +50,50 @@ Override the OnExitHook symbol to shutdown the Qt framework on exit. Default: True +Flag EnableQmlDebugging + Description: + Allow the QML debug server to be enabled via Qt arguments. + Default: False + +Custom-Setup + Setup-depends: + base == 4.*, + template-haskell == 2.*, + Cabal >= 3.8 && <3.12, + filepath >= 1.4.300 && < 1.6 + +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.*, - text >= 0.11 && < 1.3, - tagged >= 0.4 && < 0.8, - transformers >= 0.2 && < 0.5 + bytestring >= 0.11.5 && < 0.13, + containers >= 0.7 && < 0.9, + filepath >= 1.4.300 && < 1.6, + text >= 2.1.2 && < 2.2, + tagged >= 0.8.9 && < 0.9, + transformers >= 0.6.1 && < 0.7, Exposed-modules: Graphics.QML Graphics.QML.Debug Graphics.QML.Canvas Graphics.QML.Engine Graphics.QML.Marshal + Graphics.QML.Model Graphics.QML.Objects Graphics.QML.Objects.ParamNames Graphics.QML.Objects.Weak @@ -69,66 +108,84 @@ Graphics.QML.Internal.Objects Graphics.QML.Internal.Types Hs-source-dirs: src - C-sources: + Cxx-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 cbits/Object.cpp 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) CC-options: -DHSQML_USE_EXIT_HOOK + if flag(EnableQmlDebugging) + CC-options: -DQT_QML_DEBUG_NO_WARNING 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 + Include-dirs: /QT_ROOT/include CC-options: -F /QT_ROOT/lib - GHC-options: -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.3, - text >= 0.11 && < 1.3, - tagged >= 0.4 && < 0.8, - QuickCheck >= 2.4 && < 2.8, - hsqml == 0.3.* + containers >= 0.7 && < 0.9, + directory >= 1.3.9 && < 1.4, + text >= 2.1.2 && < 2.2, + tagged >= 0.8.9 && < 0.9, + QuickCheck >= 2.16.0 && < 2.17, + hsqml + Other-modules: + Graphics.QML.Test.AutoListTest + Graphics.QML.Test.DataTest + Graphics.QML.Test.Framework + Graphics.QML.Test.Harness + Graphics.QML.Test.MayGen + Graphics.QML.Test.MixedTest + Graphics.QML.Test.ScriptDSL + Graphics.QML.Test.SignalTest + Graphics.QML.Test.SimpleTest + Graphics.QML.Test.TestObject if os(darwin) && !flag(UsePkgConfig) -- Library not registered yet - GHC-options: -framework-path /QT_ROOT/lib + 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/Debug.hs b/src/Graphics/QML/Debug.hs --- a/src/Graphics/QML/Debug.hs +++ b/src/Graphics/QML/Debug.hs @@ -8,4 +8,6 @@ -- | 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 +setDebugLogLevel lvl = do + hsqmlInit + hsqmlSetDebugLoglevel lvl 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,18 +12,30 @@ initialDocument, contextObject, importPaths, - pluginPaths), + pluginPaths, + iconPath), defaultEngineConfig, Engine, runEngine, runEngineWith, runEngineAsync, runEngineLoop, + joinEngine, + killEngine, + enableHighDpiScaling, -- * Event Loop RunQML(), runEventLoop, + runEventLoopNoArgs, requireEventLoop, + setQtArgs, + getQtArgs, + QtFlag( + QtShareOpenGLContexts, + QtEnableQMLDebug), + setQtFlag, + getQtFlag, shutdownQt, EventLoopException(), @@ -45,13 +57,17 @@ import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe import qualified Data.Text as T import Data.List -import Data.Traversable +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 +import System.Environment (getProgName, getArgs, withProgName, withArgs) import System.FilePath (FilePath, isAbsolute, splitDirectories, pathSeparators) -- | Holds parameters for configuring a QML runtime engine. @@ -63,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 @@ -73,27 +95,39 @@ initialDocument = DocumentPath "main.qml", contextObject = Nothing, importPaths = [], - pluginPaths = [] + pluginPaths = [], + iconPath = Nothing } -- | Represents a QML engine. -data Engine = Engine +data Engine = Engine HsQMLEngineHandle (MVar ()) -runEngineImpl :: EngineConfig -> IO () -> IO Engine -runEngineImpl config stopCb = do +-- | Starts a new QML engine using the supplied configuration and returns +-- immediately without blocking. +runEngineAsync :: EngineConfig -> RunQML Engine +runEngineAsync config = RunQML $ do hsqmlInit + finishVar <- newEmptyMVar + let obj = contextObject config DocumentPath res = initialDocument config impPaths = importPaths config plugPaths = pluginPaths config - hndl <- sequenceA $ fmap mToHndl obj - mWithCVal (T.pack res) $ \resPtr -> + 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 hndl (HsQMLStringHandle $ castPtr resPtr) + hsqmlCreateEngine ctxHndl (HsQMLStringHandle $ castPtr resPtr) (castPtr impPtr) (castPtr plugPtr) stopCb - return Engine + 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 withMany func as cont = let rec (a:as') bs = func a (\b -> rec as' (bs . (b:))) @@ -105,28 +139,28 @@ withManyArray0 func as term cont = withMany func as $ \ptrs -> withArray0 term ptrs cont --- | Starts a new QML engine using the supplied configuration and blocks until --- the engine has terminated. -runEngine :: EngineConfig -> RunQML () -runEngine config = runEngineWith config (const $ return ()) +-- | Waits for the specified Engine to terminate. +joinEngine :: Engine -> IO () +joinEngine (Engine _ finishVar) = void $ readMVar finishVar +-- | Kills the specified Engine asynchronously. +killEngine :: Engine -> IO () +killEngine (Engine hndl _) = postJob $ hsqmlKillEngine hndl + -- | Starts a new QML engine using the supplied configuration. The \'with\' -- function is executed once the engine has been started and after it returns -- this function blocks until the engine has terminated. runEngineWith :: EngineConfig -> (Engine -> RunQML a) -> RunQML a -runEngineWith config with = RunQML $ do - finishVar <- newEmptyMVar - let stopCb = putMVar finishVar () - eng <- runEngineImpl config stopCb - let (RunQML withIO) = with eng - ret <- withIO - void $ takeMVar finishVar +runEngineWith config with = do + eng <- runEngineAsync config + ret <- with eng + RunQML $ joinEngine eng return ret --- | Starts a new QML engine using the supplied configuration and returns --- immediately without blocking. -runEngineAsync :: EngineConfig -> RunQML Engine -runEngineAsync config = RunQML $ runEngineImpl config (return ()) +-- | Starts a new QML engine using the supplied configuration and blocks until +-- the engine has terminated. +runEngine :: EngineConfig -> RunQML () +runEngine config = runEngineAsync config >>= (RunQML . joinEngine) -- | Conveniance function that both runs the event loop and starts a new QML -- engine. It blocks keeping the event loop running until the engine has @@ -154,8 +188,25 @@ -- can be started again, but only on the same operating system thread as -- before. If the event loop fails to start then an 'EventLoopException' will -- be thrown. +-- +-- If the event loop is entered for the first time then the currently set +-- runtime command line arguments will be passed to Qt. Hence, while calling +-- back to the supplied function, attempts to read the runtime command line +-- arguments using the System.Environment module will only return those +-- arguments not already consumed by Qt (per 'getQtArgs'). runEventLoop :: RunQML a -> IO a -runEventLoop (RunQML runFn) = tryRunInBoundThread $ do +runEventLoop (RunQML runFn) = do + prog <- getProgName + args <- getArgs + setQtArgs prog args + runEventLoopNoArgs . RunQML $ do + (prog', args') <- getQtArgsIO + withProgName prog' $ withArgs args' runFn + +-- | Enters the Qt event loop in the same manner as 'runEventLoop', but does +-- not perform any processing related to command line arguments. +runEventLoopNoArgs :: RunQML a -> IO a +runEventLoopNoArgs (RunQML runFn) = tryRunInBoundThread $ do hsqmlInit finishVar <- newEmptyMVar let startCb = void $ forkIO $ do @@ -194,6 +245,56 @@ Just ex -> throw ex Nothing -> return () bracket_ reqFn hsqmlEvloopRelease runFn + +-- | Sets the program name and command line arguments used by Qt and returns +-- True if successful. This must be called before the first time the Qt event +-- loop is entered otherwise it will have no effect and return False. By +-- default Qt receives no arguments and the program name is set to "HsQML". +setQtArgs :: String -> [String] -> IO Bool +setQtArgs prog args = do + hsqmlInit + withManyArray0 mWithCVal (map T.pack (prog:args)) nullPtr + (hsqmlSetArgs . castPtr) + +-- | Gets the program name and any command line arguments remaining from an +-- earlier call to 'setQtArgs' once Qt has removed any it understands, leaving +-- only application specific arguments. +getQtArgs :: RunQML (String, [String]) +getQtArgs = RunQML getQtArgsIO + +getQtArgsIO :: IO (String, [String]) +getQtArgsIO = do + argc <- hsqmlGetArgsCount + withManyArray0 mWithCVal (replicate argc $ T.pack "") nullPtr $ \argv -> do + hsqmlGetArgs $ castPtr argv + argvs <- peekArray0 nullPtr argv + Just (arg0:args) <- runMaybeT $ mapM (fmap T.unpack . mFromCVal) argvs + return (arg0, args) + +-- | Represents a Qt application flag. +data QtFlag + -- | 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 +-- return False. Setting flags once the Qt event loop is entered is +-- unsupported and will also cause this function to return False. +setQtFlag :: QtFlag -> Bool -> IO Bool +setQtFlag flag val = do + hsqmlInit + hsqmlSetFlag (internalFlag flag) val + +-- | Gets the state of one of the application flags used by Qt. +getQtFlag :: QtFlag -> RunQML Bool +getQtFlag = RunQML . hsqmlGetFlag . internalFlag -- | Shuts down and frees resources used by the Qt framework, preventing -- further use of the event loop. The framework is initialised when diff --git a/src/Graphics/QML/Internal/BindCanvas.chs b/src/Graphics/QML/Internal/BindCanvas.chs --- a/src/Graphics/QML/Internal/BindCanvas.chs +++ b/src/Graphics/QML/Internal/BindCanvas.chs @@ -9,7 +9,7 @@ import Foreign.C.Types import Foreign.Marshal.Utils import Foreign.Ptr -import Foreign.ForeignPtr.Safe +import Foreign.ForeignPtr import Foreign.Storable #include "hsqml.h" diff --git a/src/Graphics/QML/Internal/BindCore.chs b/src/Graphics/QML/Internal/BindCore.chs --- a/src/Graphics/QML/Internal/BindCore.chs +++ b/src/Graphics/QML/Internal/BindCore.chs @@ -9,6 +9,8 @@ {#import Graphics.QML.Internal.BindObj #} import Foreign.C.Types +import Foreign.ForeignPtr +import Foreign.Marshal.Utils (fromBool, toBool) import Foreign.Ptr #include @@ -31,6 +33,29 @@ hsqmlInit :: IO () hsqmlInit = hsqmlInit_ hsFreeFunPtr hsFreeStablePtr +{#fun unsafe hsqml_set_args as ^ + {id `Ptr HsQMLStringHandle'} -> + `Bool' toBool #} + +{#fun unsafe hsqml_get_args_count as ^ + {} -> + `Int' fromIntegral #} + +{#fun unsafe hsqml_get_args as ^ + {id `Ptr HsQMLStringHandle'} -> + `()' #} + +{#enum HsQMLGlobalFlag as ^ {underscoreToCase} #} + +{#fun unsafe hsqml_set_flag as ^ + {enumToCInt `HsQMLGlobalFlag', + fromBool `Bool'} -> + `Bool' toBool #} + +{#fun unsafe hsqml_get_flag as ^ + {enumToCInt `HsQMLGlobalFlag'} -> + `Bool' toBool #} + type TrivialCb = IO () foreign import ccall "wrapper" @@ -67,12 +92,26 @@ {} -> `HsQMLEventLoopStatus' cIntToEnum #} +{#pointer *HsQMLEngineHandle as ^ foreign newtype #} + +foreign import ccall "hsqml.h &hsqml_finalise_engine_handle" + hsqmlFinaliseEngineHandlePtr :: FunPtr (Ptr (HsQMLEngineHandle) -> IO ()) + +newEngineHandle :: Ptr HsQMLEngineHandle -> IO HsQMLEngineHandle +newEngineHandle p = do + fp <- newForeignPtr hsqmlFinaliseEngineHandlePtr p + return $ HsQMLEngineHandle fp + {#fun hsqml_create_engine as ^ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle', id `HsQMLStringHandle', id `Ptr HsQMLStringHandle', id `Ptr HsQMLStringHandle', withTrivialCb* `TrivialCb'} -> + `HsQMLEngineHandle' newEngineHandle* #} + +{#fun hsqml_kill_engine as ^ + {withHsQMLEngineHandle* `HsQMLEngineHandle'} -> `()' #} {#fun unsafe hsqml_set_debug_loglevel as ^ diff --git a/src/Graphics/QML/Internal/BindObj.chs b/src/Graphics/QML/Internal/BindObj.chs --- a/src/Graphics/QML/Internal/BindObj.chs +++ b/src/Graphics/QML/Internal/BindObj.chs @@ -12,8 +12,8 @@ import Foreign.C.Types import Foreign.Marshal.Utils (fromBool, toBool) import Foreign.Ptr -import Foreign.ForeignPtr.Safe -import Foreign.ForeignPtr.Unsafe +import Foreign.ForeignPtr +import qualified Foreign.ForeignPtr.Unsafe as UnsafeFPtr import Foreign.StablePtr #include "hsqml.h" @@ -77,7 +77,7 @@ isNullObjectHandle :: HsQMLObjectHandle -> Bool isNullObjectHandle (HsQMLObjectHandle fp) = - nullPtr == unsafeForeignPtrToPtr fp + nullPtr == UnsafeFPtr.unsafeForeignPtrToPtr fp {#fun unsafe hsqml_create_object as ^ {marshalStable* `a', diff --git a/src/Graphics/QML/Internal/BindPrim.chs b/src/Graphics/QML/Internal/BindPrim.chs --- a/src/Graphics/QML/Internal/BindPrim.chs +++ b/src/Graphics/QML/Internal/BindPrim.chs @@ -17,6 +17,9 @@ cIntToEnum :: Enum a => CInt -> a cIntToEnum = toEnum . fromIntegral +enumToCInt :: Enum a => a -> CInt +enumToCInt = fromIntegral . fromEnum + -- -- String -- 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 @@ -10,6 +10,9 @@ import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.BindObj +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 @@ -20,10 +23,11 @@ runErrIO :: ErrIO a -> IO () runErrIO m = do - r <- runMaybeT m - 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/Model.hs b/src/Graphics/QML/Model.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Model.hs @@ -0,0 +1,57 @@ +{-| Facility for working with Qt data models. + +This module is a placeholder for the ability to freely define QML classes which +implement the @QAbstractItemModel@ interface and functions to interact with +those models. This is not currently supported, but the functionality will be +available in a future release. + +HsQML does currently provide one mechanism for creating a Qt data model, the +@AutoListModel@ item. This item implements the @QAbstractItemModel@ interface +and provides a QML-side solution for generating a stateful Qt data model from a +succession of JavaScript arrays. + +The advantage of this over using the arrays directly is that, when the array +changes, the @AutoListModel@ can generate item add, remove, and change events +based on the differences between the old and new arrays. An simple array +binding, on the other hand, causes the entire model to be reset so that views +lose their state, cannot animate changes, etc. + +To use this facility, you must assign an @AutoListModel@ item to the @model@ +property of a QML view such as a @Repeater@ item. In turn, the @source@ +property of the @AutoListModel@ must then be bound to an expression yielding +the arrays you want to use. The @AutoListModel@ can be imported from the +@HsQML.Model 1.0@ module using an @import@ statement in your QML script and it +has several properties which can be set from QML as described below: + +[@mode@] Specifies how the model is updated when the source array changes. +Possible values are: + + [@AutoListModel.ByReset@] The model is reset entirely (default). + [@AutoListModel.ByIndex@] The elements in the old and new arrays are + compared for equality and change signals are sent for any that aren't + equal. If the length of the array has changed then elements will be added + to or removed from the end of the list model. + [@AutoListModel.ByKey@] The key function is applied to each element in the + old and new arrays. According to the key, elements which exist in both the + old and new arrays are moved to their new positions in the list model as + necessary, elements which only exist in the new array are added, and ones + which only existed in the old are removed. Where elements have been moved, + the old and new values are compared for equality and change signals are + sent for any that aren't equal. Unlike the other modes which only require + linear time to process the arrays, if elements are reordered then this mode + requires quadratic time in the worst case. + [@AutoListModel.ByKeyNoReorder@] This is the same as the ByKey mode except + that the model will not explicitly move elements to different positions, + only remove and re-add them at their new location as necessary. + +[@source@] JavaScript array containing the elements for the model. +[@equalityTest@] JavaScript function which takes two parameters, compares them +for equality, and returns a boolean. This is used by all the modes except +@ByReset@. If no function is set then the model will use the JavaScript equals +operator by default. +[@keyFunction@] JavaScript function which takes a single parameter and +returns a string key for use by the @ByKey@ and @ByKeyNoReorder@ modes. If no +function is set then the model will use JavaScript's string conversion by +default. +-} +module Graphics.QML.Model () where 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) diff --git a/test/Graphics/QML/Test/AutoListTest.hs b/test/Graphics/QML/Test/AutoListTest.hs new file mode 100644 --- /dev/null +++ b/test/Graphics/QML/Test/AutoListTest.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies #-} + +module Graphics.QML.Test.AutoListTest where + +import Graphics.QML.Marshal +import Graphics.QML.Objects +import Graphics.QML.Test.Framework +import Graphics.QML.Test.MayGen +import Graphics.QML.Test.TestObject +import Graphics.QML.Test.ScriptDSL (Expr, Prog) +import qualified Graphics.QML.Test.ScriptDSL as S + +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Control.Applicative +import Data.Int +import Data.Monoid +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + +data Mode = ByReset | ByIndex | ByKey | ByKeyNoReorder + deriving (Bounded, Enum, Eq, Show, Typeable) + +instance Marshal Mode where + type MarshalMode Mode c d = ModeBidi c + marshaller = bidiMarshaller toEnum fromEnum + +instance S.Literal Mode where + literal ByReset = S.Expr $ showString "AutoListModel.ByReset" + literal ByIndex = S.Expr $ showString "AutoListModel.ByIndex" + literal ByKey = S.Expr $ showString "AutoListModel.ByKey" + literal ByKeyNoReorder = S.Expr $ showString "AutoListModel.ByKeyNoReorder" + +data AutoListTest + = CreateAutoList Int + deriving (Eq, Show, Typeable) + +data AutoList + = SetSource [Int32] + | SetMode Mode + deriving (Eq, Show, Typeable) + +qtN, hsN :: Int -> Int +qtN n = 2*n+0 +hsN n = 2*n+1 + +autoListType :: TestType +autoListType = TestType (Proxy :: Proxy AutoList) + +testCode :: Text +testCode = T.pack $ unlines [ + "import QtQuick 2.0;", + "import HsQML.Model 1.0;", + "Item {", + " id: obj;", + " Repeater {", + " id: rep;", + " model: AutoListModel { onSourceChanged: tmr.start(); }", + " Item { property var value : modelData; }", + " }", + " property var model : rep.model;", + " Timer { id: tmr; interval: 50; onTriggered: obj.ready(); }", + " signal ready;", + " function get() {", + " var xs = [];", + " for (var i=0; i + testEnvSetJ n autoListType s) + actionRemote (CreateAutoList n) _ = + (S.saveVar (qtN n) (S.call (S.sym "Qt" `S.dot` "createQmlObject") + [S.literal testCode, S.sym "page", S.literal $ T.pack "dyn"])) <> + (S.saveVar (hsN n) (S.call (S.sym "create") [S.literal n])) + mockObjDef = [ + defMethod "create" $ \m n -> checkAction m (CreateAutoList n) + (forkMockObj m :: IO (ObjRef (MockObj AutoList)))] + +instance TestAction AutoList where + legalActionIn _ _ = True + nextActionsFor env = fromGen $ oneof [ + SetSource <$> arbitrary, + SetMode <$> arbitraryBoundedEnum] + updateEnvRaw _ = testEnvStep + actionRemote (SetSource xs) n = + S.makeCont [] ( + S.connect (S.var (qtN n) `S.dot` "ready") S.contVar <> + S.set (S.var (qtN n) `S.dot` "model" `S.dot` "source") + (S.literal xs)) <> + S.disconnect (S.var (qtN n) `S.dot` "ready") S.callee <> + S.eval (S.call (S.var (hsN n) `S.dot` "sourceSet") [ + S.call (S.var (qtN n) `S.dot` "get") []]) + actionRemote (SetMode x) n = + S.set (S.var (qtN n) `S.dot` "model" `S.dot` "mode") (S.literal x) <> + S.eval (S.call (S.var (hsN n) `S.dot` "modeSet") [S.literal x]) + mockObjDef = [ + defMethod "sourceSet" $ \m xs -> + checkAction m (SetSource xs) $ return (), + defMethod "modeSet" $ \m x -> + checkAction m (SetMode x) $ return ()] diff --git a/test/Graphics/QML/Test/Harness.hs b/test/Graphics/QML/Test/Harness.hs --- a/test/Graphics/QML/Test/Harness.hs +++ b/test/Graphics/QML/Test/Harness.hs @@ -18,6 +18,7 @@ qmlPrelude = unlines [ "import QtQuick 2.0", "import QtQuick.Window 2.0", + "import HsQML.Model 1.0", "Window {", " id: page; visible: false;", " Component.onCompleted: {", diff --git a/test/Graphics/QML/Test/ScriptDSL.hs b/test/Graphics/QML/Test/ScriptDSL.hs --- a/test/Graphics/QML/Test/ScriptDSL.hs +++ b/test/Graphics/QML/Test/ScriptDSL.hs @@ -1,11 +1,15 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP, FlexibleInstances #-} module Graphics.QML.Test.ScriptDSL where +import Data.Bits import Data.Char import Data.Int import Data.List import Data.Monoid +#if MIN_VERSION_base(4,11,0) +import Data.Semigroup +#endif import Data.Text (Text) import qualified Data.Text as T import Numeric @@ -14,9 +18,17 @@ data Prog = Prog ShowS ShowS +#if MIN_VERSION_base(4,11,0) +instance Semigroup Prog where + (Prog a1 b1) <> (Prog a2 b2) = Prog (a1 . a2) (b2 . b1) + instance Monoid Prog where mempty = Prog id id +#else +instance Monoid Prog where + mempty = Prog id id mappend (Prog a1 b1) (Prog a2 b2) = Prog (a1 . a2) (b2 . b1) +#endif showProg :: Prog -> ShowS showProg (Prog a b) = a . b @@ -47,12 +59,17 @@ foldr (.) id . map f $ T.unpack txt) . showChar '"') where f '\"' = showString "\\\"" f '\\' = showString "\\\\" - f c | ord c < 32 = hexEsc c - | ord c > 127 = hexEsc c - | otherwise = showChar c + f c | ord c < 32 = hexEsc c + | ord c > 0xffff = surEsc c + | ord c > 127 = hexEsc c + | otherwise = showChar c hexEsc c = let h = showHex (ord c) in showString "\\u" . showString ( replicate (4 - (length $ h "")) '0') . h + surEsc c = let v = ord c - 0x10000 + hi = chr $ (v `shiftR` 10) + 0xD800 + lo = chr $ (v .&. 0x3ff) + 0xDC00 + in hexEsc hi . hexEsc lo instance Literal a => Literal (Maybe a) where literal Nothing = Expr $ showString "null" @@ -122,10 +139,10 @@ disconnect :: Expr -> Expr -> Prog disconnect sig fn = eval $ sig `dot` "disconnect" `call` [fn] -makeCont :: [String] -> Prog -> Prog -> Prog -makeCont args (Prog a1 b1) (Prog a2 b2) = - Prog (showString "var cont = function(" . farg . showString ") {\n" . a2) - (b2 . showString "};\n" . a1 . b1) +makeCont :: [String] -> Prog -> Prog +makeCont args (Prog a b) = + Prog (showString "var cont = function(" . farg . showString ") {\n") + (showString "};\n" . a . b) where farg = foldr1 (.) $ (id:) $ intersperse (showChar ',') $ map showString args diff --git a/test/Graphics/QML/Test/SignalTest.hs b/test/Graphics/QML/Test/SignalTest.hs --- a/test/Graphics/QML/Test/SignalTest.hs +++ b/test/Graphics/QML/Test/SignalTest.hs @@ -63,7 +63,7 @@ chainSignal :: Int -> [String] -> String -> String -> Prog chainSignal n args sig fn = S.makeCont args ((S.connect (S.var n `S.dot` sig) S.contVar) `mappend` - (S.eval $ (S.var n) `S.dot` fn `S.call` [])) + (S.eval $ (S.var n) `S.dot` fn `S.call` [])) `mappend` (S.disconnect (S.var n `S.dot` sig) S.callee) testSignal :: Int -> String -> String -> Expr -> Prog diff --git a/test/Graphics/QML/Test/SimpleTest.hs b/test/Graphics/QML/Test/SimpleTest.hs --- a/test/Graphics/QML/Test/SimpleTest.hs +++ b/test/Graphics/QML/Test/SimpleTest.hs @@ -152,7 +152,7 @@ actionRemote (SPSetObject v) n = setProp n "propObjectW" $ S.var v mockObjDef = [ -- There are seperate properties for testing accessors and mutators - -- becasue QML produces spurious reads when writing. + -- because QML produces spurious reads when writing. defPropertyRO "propIntConst" (\m -> expectAction m $ \a -> case a of SPGetIntConst v -> return $ Right v diff --git a/test/Test1.hs b/test/Test1.hs --- a/test/Test1.hs +++ b/test/Test1.hs @@ -8,6 +8,7 @@ import Graphics.QML.Test.SimpleTest import Graphics.QML.Test.SignalTest import Graphics.QML.Test.MixedTest +import Graphics.QML.Test.AutoListTest import Data.Proxy import System.Exit @@ -38,7 +39,8 @@ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Bool])), checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Int32])), checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Double])), - checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Text]))] + checkProperty 20 $ TestType (Proxy :: Proxy (DataTest [Text])), + checkProperty 100 $ TestType (Proxy :: Proxy AutoListTest)] if and rs then exitSuccess else exitFailure