hsqml 0.3.3.0 → 0.3.7.0
raw patch · 40 files changed
Files
- CHANGELOG +39/−0
- LICENSE +2/−1
- README +0/−10
- README.md +16/−0
- Setup.hs +145/−168
- SetupNoTH.hs +0/−294
- cbits/Canvas.cpp +1/−0
- cbits/Class.cpp +33/−18
- cbits/Class.h +1/−0
- cbits/ClipboardHelper.cpp +9/−0
- cbits/ClipboardHelper.h +16/−0
- cbits/Engine.cpp +143/−23
- cbits/Engine.h +39/−8
- cbits/HighDpiScaling.cpp +5/−0
- cbits/HighDpiScaling.h +9/−0
- cbits/Intrinsics.cpp +1/−0
- cbits/Manager.cpp +187/−21
- cbits/Manager.h +25/−9
- cbits/Model.cpp +340/−0
- cbits/Model.h +85/−0
- cbits/Object.cpp +25/−15
- cbits/Object.h +2/−2
- cbits/hsqml.h +28/−4
- hsqml.cabal +89/−32
- src/Graphics/QML/Debug.hs +3/−1
- src/Graphics/QML/Engine.hs +128/−27
- src/Graphics/QML/Internal/BindCanvas.chs +1/−1
- src/Graphics/QML/Internal/BindCore.chs +39/−0
- src/Graphics/QML/Internal/BindObj.chs +3/−3
- src/Graphics/QML/Internal/BindPrim.chs +3/−0
- src/Graphics/QML/Internal/Marshal.hs +8/−4
- src/Graphics/QML/Marshal.hs +15/−8
- src/Graphics/QML/Model.hs +57/−0
- src/Graphics/QML/Objects.hs +16/−13
- test/Graphics/QML/Test/AutoListTest.hs +107/−0
- test/Graphics/QML/Test/Harness.hs +1/−0
- test/Graphics/QML/Test/ScriptDSL.hs +25/−8
- test/Graphics/QML/Test/SignalTest.hs +1/−1
- test/Graphics/QML/Test/SimpleTest.hs +1/−1
- test/Test1.hs +3/−1
CHANGELOG view
@@ -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.
LICENSE view
@@ -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.
− README
@@ -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/
+ README.md view
@@ -0,0 +1,16 @@+# HsQML++[](https://github.com/prolic/HsQML/actions?query=workflow%3ATests)+[](https://ci.appveyor.com/project/prolic/hsqml)++HsQML is a Haskell binding to Qt Quick, a cross-platform framework for creating+graphical user interfaces. For further information on installing and using it,+please see the project's web site.++**Home Page:** http://www.gekkou.co.uk/software/hsqml/+**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.
Setup.hs view
@@ -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
− SetupNoTH.hs
@@ -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'
cbits/Canvas.cpp view
@@ -1,4 +1,5 @@ #include "Canvas.h"+#include "Engine.h" #include "Manager.h" #include <QtCore/qmath.h>
cbits/Class.cpp view
@@ -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; i<mMethodCount; i++) {- gManager->freeFun((HsFunPtr)mMethods[i]);- }- for (unsigned int i=0; i<2*mPropertyCount; i++) {- if (mProperties[i]) {- gManager->freeFun((HsFunPtr)mProperties[i]);- }- }- 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; i<mMethodCount; i++) {+ gManager->freeFun((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()
cbits/Class.h view
@@ -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);
+ cbits/ClipboardHelper.cpp view
@@ -0,0 +1,9 @@+#include "ClipboardHelper.h"++HsQMLClipboardHelper::HsQMLClipboardHelper(QObject *parent)+ : QObject(parent) {}++void HsQMLClipboardHelper::copyText(const QString &text) {+ QClipboard *clipboard = QGuiApplication::clipboard();+ clipboard->setText(text);+}
+ cbits/ClipboardHelper.h view
@@ -0,0 +1,16 @@+#ifndef CLIPBOARDHELPER_H+#define CLIPBOARDHELPER_H++#include <QtGui/QGuiApplication>+#include <QtGui/QClipboard>+#include <QtCore/QObject>++class HsQMLClipboardHelper : public QObject {+ Q_OBJECT+public:+ explicit HsQMLClipboardHelper(QObject *parent = nullptr);++ Q_INVOKABLE void copyText(const QString &text);+};++#endif // CLIPBOARDHELPER_H
cbits/Engine.cpp view
@@ -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<HsFunPtr>(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<QQuickWindow*>(obj); QQuickItem* item = qobject_cast<QQuickItem*>(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<HsQMLObjectProxy*>(contextObject);- config.initialURL = *reinterpret_cast<QString*>(initialURL);+ Q_ASSERT (gManager);++ HsQMLEngineProxy* proxy = new HsQMLEngineProxy();+ HsQMLEngineCreateEvent* config = new HsQMLEngineCreateEvent(proxy);++ config->contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);+ config->initialURL = *reinterpret_cast<QString*>(initialURL); for (QString** p = reinterpret_cast<QString**>(importPaths); *p; p++) {- config.importPaths.push_back(**p);+ config->importPaths.push_back(**p); } for (QString** p = reinterpret_cast<QString**>(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<HsQMLEngineHandle*>(proxy);+}++extern "C" void hsqml_kill_engine(+ HsQMLEngineHandle* hndl)+{+ HsQMLEngineProxy* proxy = reinterpret_cast<HsQMLEngineProxy*>(hndl);++ Q_ASSERT(gManager->isEventThread());+ proxy->kill();+}++extern void hsqml_finalise_engine_handle(+ HsQMLEngineHandle* hndl)+{+ HsQMLEngineProxy* proxy = (HsQMLEngineProxy*)hndl;+ proxy->deref(HsQMLEngineProxy::Handle); }
cbits/Engine.h view
@@ -1,8 +1,9 @@ #ifndef HSQML_ENGINE_H #define HSQML_ENGINE_H -#include <QtCore/QScopedPointer>+#include <QtCore/QEvent> #include <QtCore/QString>+#include <QtCore/QStringList> #include <QtCore/QUrl> #include <QtQml/QQmlEngine> #include <QtQml/QQmlContext>@@ -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<QObject*> mObjects;+ QList<HsQMLObjectProxy*> mGlobals;+ QList<QObject*> mResources; HsQMLTrivialCb mStopCb; };
+ cbits/HighDpiScaling.cpp view
@@ -0,0 +1,5 @@+#include "QtGui/QGuiApplication"++extern "C" void hsqml_enable_high_dpi_scaling() {+ QGuiApplication::setAttribute(Qt::AA_EnableHighDpiScaling);+}
+ cbits/HighDpiScaling.h view
@@ -0,0 +1,9 @@+#ifdef __cplusplus+extern "C" {+#endif++void hsqml_enable_high_dpi_scaling();++#ifdef __cplusplus+}+#endif
cbits/Intrinsics.cpp view
@@ -3,6 +3,7 @@ #include <QtQml/QJSValue> #include "Manager.h"+#include "Engine.h" /* String */ extern "C" size_t hsqml_get_string_size()
cbits/Manager.cpp view
@@ -4,12 +4,22 @@ #include <QtCore/QMetaType> #include <QtCore/QMutexLocker> #include <QtCore/QThread>+#include <QtQml/QQmlDebuggingEnabler>+#include <QtCore/QDebug>+#include <QtCore/QProcessEnvironment>+#include <QtCore/QLoggingCategory>+#include <QtNetwork/QTcpServer>+#include <QtNetwork/QTcpSocket> #ifdef Q_OS_MAC #include <pthread.h> #endif #include "Canvas.h"+#include "Class.h"+#include "ClipboardHelper.h"+#include "Engine.h" #include "Manager.h"+#include "Model.h" #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<char*>& 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>("HsQMLEngineConfig"); qmlRegisterType<HsQMLCanvas>("HsQML.Canvas", 1, 0, "HaskellCanvas"); qmlRegisterType<HsQMLContextControl>( "HsQML.Canvas", 1, 0, "OpenGLContextControl");+ qmlRegisterType<HsQMLAutoListModel>(+ "HsQML.Model", 1, 0, "AutoListModel");+ qmlRegisterType<HsQMLClipboardHelper>(+ "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<HsQMLObjectEvent*>(ev)->process(); break;}+ case HsQMLManagerApp::CreateEngineEvent: {+ HsQMLEngineCreateEvent* create =+ static_cast<HsQMLEngineCreateEvent*>(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<QString**>(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<argc; i++) {+ QString* string = reinterpret_cast<QString*>(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));+ } }
cbits/Manager.h view
@@ -3,19 +3,23 @@ #include <QtCore/QAtomicPointer> #include <QtCore/QAtomicInt>+#include <QtCore/QByteArray> #include <QtCore/QMutex> #include <QtCore/QSet> #include <QtCore/QString>+#include <QtCore/QStringList> #include <QtCore/QVariant>+#include <QtCore/QVector> #include <QtWidgets/QApplication>+#include <QtGui/QIcon> #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<char*>& 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<QByteArray> mArgs;+ QVector<char*> mArgsPtrs; QSet<const QObject*> mObjectSet;+ QVector<HsQMLClass*> 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::Type>(QEvent::User+PendingJobsEventIndex); static const QEvent::Type RemoveGCLockEvent = static_cast<QEvent::Type>(QEvent::User+RemoveGCLockEventIndex);+ static const QEvent::Type CreateEngineEvent =+ static_cast<QEvent::Type>(QEvent::User+CreateEngineEventIndex); private: Q_DISABLE_COPY(HsQMLManagerApp) - int mArgC;- char mArg0;- char* mArgV; QVariant::Handler mHookedHandler;+ int mArgC; QApplication mApp; };
+ cbits/Model.cpp view
@@ -0,0 +1,340 @@+#include <QtCore/QMultiHash>+#include <QtCore/QDebug>++#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<int, QByteArray> HsQMLAutoListModel::roleNames() const+{+ QHash<int, QByteArray> 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<srcLen; i++) {+ mOldModel.append(Element(mSource.property(i)));+ }+ endResetModel();++ // This mode doesn't maintain the hashes+ mRehash = true;+}++void HsQMLAutoListModel::updateModelByIndex()+{+ int srcLen = sourceLength();+ int oldLen = mOldModel.size();++ // Notify views which elements have changed+ for (int i=0; i<qMin(srcLen, oldLen); i++) {+ handleInequality(mSource.property(i), mOldModel, i);+ }++ // Add or remove elements to/from the end of the list+ if (srcLen > 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; i++) {+ mOldModel.append(Element(mSource.property(i)));+ }+ endInsertRows();+ }+ else if (oldLen > 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<QString, int> SrcDict;+ SrcDict srcDict;+ if (reorder) {+ for (int i=0; i<srcLen; i++) {+ QJSValue srcVal = mSource.property(i);+ srcDict.insert(keyFunction(srcVal), i);+ }+ }++ // Build a map of element key's previous indices in the old model+ typedef QMultiHash<QString, int> 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<srcLen; i++) {+ QJSValue srcVal = mSource.property(i);+ QString srcKey = keyFunction(srcVal);++ ModelDict::iterator it = modelDict.find(srcKey);+ if (it != modelDict.end()) {+ const int elemIdx = *it;+ Q_ASSERT(elemIdx >= 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();+ }+}
+ cbits/Model.h view
@@ -0,0 +1,85 @@+#ifndef HSQML_MODEL_H+#define HSQML_MODEL_H++#include <QtCore/QAbstractListModel>+#include <QtCore/QVector>+#include <QtQml/QJSValue>+#include <QtQml/QQmlParserStatus>++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<int, QByteArray> 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<Element> 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
cbits/Object.cpp view
@@ -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));
cbits/Object.h view
@@ -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<HsQMLObjectFinaliser::Ref, 1> Finalisers; Finalisers mFinalisers;
cbits/hsqml.h view
@@ -8,13 +8,11 @@ #include <stddef.h> #include <HsFFI.h> -/* 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;
hsqml.cabal view
@@ -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/
src/Graphics/QML/Debug.hs view
@@ -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
src/Graphics/QML/Engine.hs view
@@ -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
src/Graphics/QML/Internal/BindCanvas.chs view
@@ -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"
src/Graphics/QML/Internal/BindCore.chs view
@@ -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 <HsFFI.h>@@ -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 ^
src/Graphics/QML/Internal/BindObj.chs view
@@ -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',
src/Graphics/QML/Internal/BindPrim.chs view
@@ -17,6 +17,9 @@ cIntToEnum :: Enum a => CInt -> a cIntToEnum = toEnum . fromIntegral +enumToCInt :: Enum a => a -> CInt+enumToCInt = fromIntegral . fromEnum+ -- -- String --
src/Graphics/QML/Internal/Marshal.hs view
@@ -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
src/Graphics/QML/Marshal.hs view
@@ -3,6 +3,7 @@ TypeFamilies, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Type classs and instances for marshalling values between Haskell and QML. module Graphics.QML.Marshal (@@ -49,12 +50,15 @@ import Control.Monad import Control.Monad.Trans.Maybe+import qualified Data.ByteString as BS+import qualified Data.ByteString.Unsafe as BSU import Data.Tagged import Data.Int import Data.Text (Text)-import qualified Data.Text.Foreign as T+import qualified Data.Text.Encoding as TE import Foreign.C.Types import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr import Foreign.Storable @@ -138,21 +142,24 @@ -- Text/QString built-in type -- + instance Marshal Text where type MarshalMode Text c d = ModeBidi c marshaller = Marshaller { mTypeCVal_ = Tagged tyString, mFromCVal_ = \ptr -> errIO $ do pair <- alloca (\bufPtr -> do- len <- hsqmlReadString (- HsQMLStringHandle $ castPtr ptr) bufPtr+ len <- hsqmlReadString (HsQMLStringHandle $ castPtr ptr) bufPtr buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- uncurry T.fromPtr pair,+ return (buf, len))+ let (buf, len) = pair+ bs <- BS.packCStringLen (castPtr buf, len * 2)+ return $ TE.decodeUtf16LE bs, mToCVal_ = \txt ptr -> do- array <- hsqmlWriteString- (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)- T.unsafeCopyToPtr txt (castPtr array),+ let bs = TE.encodeUtf16LE txt+ ucs2Length = BS.length bs `div` 2+ array <- hsqmlWriteString ucs2Length (HsQMLStringHandle $ castPtr ptr)+ BSU.unsafeUseAsCStringLen bs (\(bsp, bslen) -> copyBytes (castPtr array) bsp bslen), mWithCVal_ = \txt f -> withStrHndl $ \(HsQMLStringHandle ptr) -> do mToCVal txt $ castPtr ptr
+ src/Graphics/QML/Model.hs view
@@ -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
src/Graphics/QML/Objects.hs view
@@ -245,7 +245,7 @@ in Tagged $ MethodTypeInfo [] typ mkUniformFunc :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,+ (Marshal tt, MethodSuffix ms) => (tt -> ms) -> UniformFunc mkUniformFunc f = \pt pv -> do@@ -263,9 +263,12 @@ instance (IsVoidIO b) => IsVoidIO (a -> b) instance IsVoidIO VoidIO -mkSpecialFunc :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,- MethodSuffix ms, IsVoidIO ms) => (tt -> ms) -> UniformFunc+mkSpecialFunc+ :: forall tt ms.+ ( Marshal tt+ , MethodSuffix ms)+ => (tt -> ms)+ -> UniformFunc mkSpecialFunc f = \pt pv -> do hndl <- hsqmlGetObjectFromPointer pt this <- mFromHndl hndl@@ -278,7 +281,7 @@ -- there may be zero or more parameter arguments followed by an optional return -- argument in the IO monad. defMethod :: forall tt ms.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, MethodSuffix ms) =>+ (Marshal tt, MethodSuffix ms) => String -> (tt -> ms) -> Member (GetObjType tt) defMethod name f = let crude = untag (mkMethodTypes :: Tagged ms MethodTypeInfo)@@ -341,7 +344,7 @@ -- This function is safe to call from any thread. Any attached signal handlers -- will be executed asynchronously on the event loop thread. fireSignal ::- forall tt skv. (Marshal tt, CanPassTo tt ~ Yes, IsObjType tt ~ Yes,+ forall tt skv. (Marshal tt, SignalKeyValue skv) => skv -> tt -> SignalValueParams skv fireSignal key this = let start cnt = postJob $ do@@ -365,8 +368,8 @@ newtype SignalKey p = SignalKey Unique -- | Creates a new 'SignalKey'. -newSignalKey :: (SignalSuffix p) => IO (SignalKey p)-newSignalKey = fmap SignalKey $ newUnique+newSignalKey :: IO (SignalKey p)+newSignalKey = fmap SignalKey newUnique -- | Instances of the 'SignalKeyClass' class identify distinct signals by type. -- The associated 'SignalParams' type specifies the signal's signature.@@ -419,7 +422,7 @@ -- | Defines a named constant property using an accessor function in the IO -- monad. defPropertyConst :: forall tt tr.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes) => String -> (tt -> IO tr) -> Member (GetObjType tt) defPropertyConst name g = Member ConstPropertyMember@@ -433,7 +436,7 @@ -- | Defines a named read-only property using an accessor function in the IO -- monad. defPropertyRO :: forall tt tr.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes) => String -> (tt -> IO tr) -> Member (GetObjType tt) defPropertyRO name g = Member PropertyMember@@ -446,7 +449,7 @@ -- | Defines a named read-only property with an associated signal. defPropertySigRO :: forall tt tr skv.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, SignalKeyValue skv) => String -> skv -> (tt -> IO tr) -> Member (GetObjType tt) defPropertySigRO name key g = Member PropertyMember@@ -460,7 +463,7 @@ -- | Defines a named read-write property using a pair of accessor and mutator -- functions in the IO monad. defPropertyRW :: forall tt tr.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) => String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt) defPropertyRW name g s = Member PropertyMember@@ -473,7 +476,7 @@ -- | Defines a named read-write property with an associated signal. defPropertySigRW :: forall tt tr skv.- (Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, Marshal tr,+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes, SignalKeyValue skv) => String -> skv -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt)
+ test/Graphics/QML/Test/AutoListTest.hs view
@@ -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<rep.count; i++) {xs.push(rep.itemAt(i).value);}",+ " return xs;",+ " }",+ "}"]++instance TestAction AutoListTest where+ legalActionIn _ _ = True+ nextActionsFor env = pure . CreateAutoList $ testEnvNextJ env+ updateEnvRaw (CreateAutoList n) = testEnvStep . testEnvSerial (\s ->+ 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 ()]
test/Graphics/QML/Test/Harness.hs view
@@ -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: {",
test/Graphics/QML/Test/ScriptDSL.hs view
@@ -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
test/Graphics/QML/Test/SignalTest.hs view
@@ -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
test/Graphics/QML/Test/SimpleTest.hs view
@@ -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
test/Test1.hs view
@@ -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