hsqml 0.2.0.3 → 0.3.7.0
raw patch · 60 files changed
Files
- CHANGELOG +99/−2
- LICENSE +2/−1
- README.md +16/−0
- Setup.hs +195/−147
- cbits/Canvas.cpp +863/−0
- cbits/Canvas.h +295/−0
- cbits/Class.cpp +178/−0
- cbits/Class.h +41/−0
- cbits/ClipboardHelper.cpp +9/−0
- cbits/ClipboardHelper.h +16/−0
- cbits/Engine.cpp +241/−0
- cbits/Engine.h +81/−0
- cbits/HighDpiScaling.cpp +5/−0
- cbits/HighDpiScaling.h +9/−0
- cbits/HsQMLClass.cpp +0/−146
- cbits/HsQMLClass.h +0/−39
- cbits/HsQMLEngine.cpp +0/−95
- cbits/HsQMLEngine.h +0/−68
- cbits/HsQMLIntrinsics.cpp +0/−77
- cbits/HsQMLManager.cpp +0/−325
- cbits/HsQMLManager.h +0/−109
- cbits/HsQMLObject.cpp +0/−329
- cbits/HsQMLObject.h +0/−71
- cbits/HsQMLWindow.cpp +0/−107
- cbits/HsQMLWindow.h +0/−45
- cbits/Intrinsics.cpp +171/−0
- cbits/Manager.cpp +632/−0
- cbits/Manager.h +153/−0
- cbits/Model.cpp +340/−0
- cbits/Model.h +85/−0
- cbits/Object.cpp +463/−0
- cbits/Object.h +102/−0
- cbits/hsqml.h +167/−24
- hsqml.cabal +127/−43
- src/Graphics/QML.hs +3/−19
- src/Graphics/QML/Canvas.hs +182/−0
- src/Graphics/QML/Debug.hs +3/−1
- src/Graphics/QML/Engine.hs +208/−87
- src/Graphics/QML/Internal/BindCanvas.chs +89/−0
- src/Graphics/QML/Internal/BindCore.chs +47/−10
- src/Graphics/QML/Internal/BindObj.chs +72/−17
- src/Graphics/QML/Internal/BindPrim.chs +137/−22
- src/Graphics/QML/Internal/Marshal.hs +205/−77
- src/Graphics/QML/Internal/MetaObj.hs +101/−48
- src/Graphics/QML/Internal/Objects.hs +62/−106
- src/Graphics/QML/Internal/Types.hs +22/−0
- src/Graphics/QML/Marshal.hs +292/−108
- src/Graphics/QML/Model.hs +57/−0
- src/Graphics/QML/Objects.hs +337/−274
- src/Graphics/QML/Objects/ParamNames.hs +59/−0
- src/Graphics/QML/Objects/Weak.hs +120/−0
- test/Graphics/QML/Test/AutoListTest.hs +107/−0
- test/Graphics/QML/Test/DataTest.hs +53/−0
- test/Graphics/QML/Test/Framework.hs +22/−9
- test/Graphics/QML/Test/GenURI.hs +0/−51
- test/Graphics/QML/Test/Harness.hs +21/−12
- test/Graphics/QML/Test/ScriptDSL.hs +46/−20
- test/Graphics/QML/Test/SignalTest.hs +20/−62
- test/Graphics/QML/Test/SimpleTest.hs +21/−86
- test/Test1.hs +28/−4
CHANGELOG view
@@ -1,9 +1,106 @@ 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.+ * Added facility for controlling the OpenGL context.+ * Added defSignal variant with ability to set parameter names.+ * Added option for setting the module and plugin search paths.+ * Changed Setup script to set QT_SELECT (base >= 4.7).+ * Fixed crash resizing canvas in Inline mode.+ * Fixed leaking stable pointers when objects are collected.+ * Fixed Canvas delegate marshaller to fail on invalid values.+ * Fixed discrepancy between kinds of type conversion.++release-0.3.2.1 - 2014.11.29++ * Added function to shutdown the Qt framework.+ * Fixed intermittent crash on exit under Linux.+ * Fixed reanimated objects being passed to QML as undefined.+ * Fixed typo in the names of implicit property signals.++release-0.3.2.0 - 2014.11.13++ * Added OpenGL canvas support.+ * Added weak references and object finalisers.+ * Added FactoryPool abstraction.+ * Added To-only custom marshallers.+ * Added Ignored type.+ * Relaxed Cabal dependency constraint on 'text'.++release-0.3.1.1 - 2014.07.31++ * Fixed crash when storing Haskell objects in QML variants.+ * Fixed corrupted logging output caused by threading.++release-0.3.1.0 - 2014.06.11++ * Added properties with constant annotation.+ * Added runtime warning for users of the non-threaded RTS.+ * Added non-TH version of Setup.hs.+ * Relaxed Cabal dependency constraint on 'transformers'.+ * Fixed premature garbage collection of QML objects.+ * Fixed intermittent crash on exit when firing signals.+ * Fixed crash when using Cmd-Q to exit on MacOS.++release-0.3.0.0 - 2014.05.04++ * Ported to Qt 5 and Qt Quick 2+ * Added type-free mechanism for defining classes.+ * Added type-free mechanism for defining signal keys.+ * Added property signals.+ * Added marshallers for Bool, Maybe, and lists.+ * Added less polymorphic aliases for def functions.+ * Replaced Tagged with Proxy in public API.+ * Removed marshallers for URI and String.+ * New design for marshalling type-classes (again).+ * Generalised facility for user-defined Marshal instances.+ * Relaxed Cabal dependency constraint on 'QuickCheck'.+ * Fixed GHCi on Windows with pre-7.8 GHC.+ release-0.2.0.3 - 2014.02.01 - * Added mechanism to force enable GHCi workaround library. - * Fixed reference name of extra GHCi library on Windows.+ * Added mechanism to force enable GHCi workaround library.+ * Fixed reference name of extra GHCi library. release-0.2.0.2 - 2014.01.18
LICENSE view
@@ -1,4 +1,5 @@-Copyright (c)2010-2014, Robin KAY+Copyright (c)2010-2018, Robin KAY+Copyright (c)2025, Sascha-Oliver Prolic All rights reserved.
+ 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,125 +1,124 @@-#!/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.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 System.FilePath+import System.Info (os) --- Use Template Haskell to support both the pre- and post-1.18 Cabal API-$(let- newCabalAPI = cabalVersion >= Version [1,17,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- nothingE = cnameE "Nothing"- falseE = cnameE "False"- -- 'LocalBuildInfo' record changed fields in Cabal 1.18- extractCLBI = if newCabalAPI- 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 newCabalAPI- 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 newCabalAPI- then AppE (app3E (app3E (vnameE "rawSystemStdInOut")- (vnameE "v") (vnameE "p") (vnameE "a"))- nothingE nothingE nothingE) falseE - else app2E (app3E (vnameE "rawSystemStdInOut")- (vnameE "v") (vnameE "p") (vnameE "a")) nothingE falseE- -- 'programPostConf' field changed signature in Cabal 1.18- noPostConf = if newCabalAPI- then LamE [WildP, vnameP "c"] $ AppE (vnameE "return") (vnameE "c")- else LamE [WildP, WildP] $ AppE (vnameE "return") (cnameE "[]")- in return [- 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) []]])+import Text.Read (readMaybe) main :: IO ()-main = defaultMainWithHooks simpleUserHooks {- confHook = confWithQt, buildHook = buildWithQt,- copyHook = copyWithQt, instHook = instWithQt,- regHook = regWithQt}+main = do+ -- If system uses qtchooser(1) then encourage it to choose Qt 5+ env <- getEnvironment+ case lookup "QT_SELECT" env of+ Nothing -> setEnv "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 $ do- lib <- library pkgDesc- str <- lookup name $ customFieldsBI $ libBuildInfo lib- simpleParse str+ 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 condLib = fromJust $ condLibrary gpd- fixCondLib lib = lib {- libBuildInfo = substPaths mocPath cppPath $ libBuildInfo lib} - condLib' = mapCondTree fixCondLib condLib- gpd' = gpd {condLibrary = Just $ condLib'}+ 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,+ 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 + -- 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', withGHCiLib = withGHCiLib lbi || forceGHCiLib} -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)+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) id id +-- Helper function to map over PerCompilerFlavor+mapPerCompilerFlavor :: (String -> String) -> PerCompilerFlavor [String] -> PerCompilerFlavor [String]+mapPerCompilerFlavor f (PerCompilerFlavor gcc other) = PerCompilerFlavor (map f gcc) (map f other)++-- Function to replace paths and options in BuildInfo substPaths :: Maybe FilePath -> Maybe FilePath -> BuildInfo -> BuildInfo substPaths mocPath cppPath build =- let toRoot = takeDirectory . takeDirectory . fromMaybe ""- substPath = replacePrefix "/QT_ROOT" (toRoot mocPath) .- replacePrefix "/SYS_ROOT" (toRoot cppPath)- in build {extraLibDirs = map substPath $ extraLibDirs build,- includeDirs = map substPath $ includeDirs build}--replacePrefix :: (Eq a) => [a] -> [a] -> [a] -> [a]-replacePrefix old new xs =- case stripPrefix old xs of- Just ys -> new ++ ys- Nothing -> xs+ 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 ()@@ -128,10 +127,7 @@ libs' <- maybeMapM (\lib -> fmap (\lib' -> lib {libBuildInfo = lib'}) $ fixQtBuild verb lbi $ libBuildInfo lib) $ library pkgDesc- exes' <- mapM (\exe -> fmap (\exe' ->- exe {buildInfo = exe'}) $ fixQtBuild verb lbi $ buildInfo exe) $- executables pkgDesc- let pkgDesc' = pkgDesc {library = libs', executables = exes'}+ let pkgDesc' = pkgDesc {library = libs'} lbi' = if (needsGHCiFix pkgDesc lbi) then lbi {withGHCiLib = False, splitObjs = False} else lbi buildHook simpleUserHooks pkgDesc' lbi' hooks flags@@ -143,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- (_,line,_) <- rawSystemStdErr verb path ["-v"]- return $- findSubseq (stripPrefix "(Qt ") line >>=- Just . takeWhile (\c -> isDigit c || c == '.') >>=- simpleParse,- 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 [4,7] []) (earlierVersion $ Version [5,0] [])+ (orLaterVersion $ mkVersion [5,0]) (earlierVersion $ mkVersion [6,0]) copyWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()@@ -220,35 +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 <- generateRegistrationInfo- verb pkg lib lbi clbi inplace dist- let instPkgInfo' = if (needsGHCiFix pkg lbi)- then instPkgInfo {I.extraGHCiLibraries =- mkGHCiFixLibRefName pkg : I.extraGHCiLibraries instPkgInfo}- else 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 ::@@ -267,12 +289,38 @@ 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
@@ -0,0 +1,863 @@+#include "Canvas.h"+#include "Engine.h"+#include "Manager.h"++#include <QtCore/qmath.h>+#include <QtQuick/QSGSimpleTextureNode>+#include <QtQuick/QSGTexture>+#include <QtQuick/QSGTransformNode>+#include <QtQuick/QQuickWindow>++HsQMLGLCallbacks::HsQMLGLCallbacks(+ HsQMLGLSetupCb setupCb, HsQMLGLCleanupCb cleanupCb,+ HsQMLGLSyncCb syncCb, HsQMLGLPaintCb paintCb)+ : mSetupCb(setupCb)+ , mCleanupCb(cleanupCb)+ , mSyncCb(syncCb)+ , mPaintCb(paintCb)+{}++HsQMLGLCallbacks::~HsQMLGLCallbacks()+{+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mSyncCb));+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mPaintCb));+}++HsQMLGLDelegateImpl::HsQMLGLDelegateImpl(HsQMLGLMakeCallbacksCb makeContextCb)+ : mMakeCallbacksCb(makeContextCb)+{}++HsQMLGLDelegateImpl::~HsQMLGLDelegateImpl()+{+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mMakeCallbacksCb));+}++HsQMLGLDelegate::HsQMLGLDelegate()+{+}++HsQMLGLDelegate::~HsQMLGLDelegate()+{+}++void HsQMLGLDelegate::setup(HsQMLGLMakeCallbacksCb makeContextCb)+{+ mImpl = new HsQMLGLDelegateImpl(makeContextCb);+}++bool HsQMLGLDelegate::isValid()+{+ return mImpl;+}++HsQMLGLDelegate::CallbacksRef HsQMLGLDelegate::makeCallbacks()+{+ CallbacksRef dataPtr;+ if (mImpl) {+ HsQMLGLSetupCb setupCb;+ HsQMLGLCleanupCb cleanupCb;+ HsQMLGLSyncCb syncCb;+ HsQMLGLPaintCb paintCb;+ mImpl->mMakeCallbacksCb(&setupCb, &cleanupCb, &syncCb, &paintCb);+ dataPtr = new HsQMLGLCallbacks(setupCb, cleanupCb, syncCb, paintCb);+ }+ return dataPtr;+}++HsQMLWindowInfoImpl::HsQMLWindowInfoImpl(QQuickWindow* win)+ : mWin(win)+ , mBelowCount(0)+ , mBelowClear(false)+{}++HsQMLWindowInfo::HsQMLWindowInfo()+{}++HsQMLWindowInfo HsQMLWindowInfo::getWindowInfo(QQuickWindow* win)+{+ const char* propName = "_hsqml_window_info";+ HsQMLWindowInfo info = win->property(propName).value<HsQMLWindowInfo>();+ if (!info.mImpl) {+ info.mImpl = new HsQMLWindowInfoImpl(win);+ win->setProperty(propName, QVariant::fromValue(info));+ }+ return info;+}++void HsQMLWindowInfo::addBelow()+{+ Q_ASSERT(mImpl);+ if (0 == mImpl->mBelowCount++) {+ mImpl->mWin->setClearBeforeRendering(false);+ }+}++void HsQMLWindowInfo::removeBelow()+{+ Q_ASSERT(mImpl);+ if (0 == --mImpl->mBelowCount) {+ mImpl->mWin->setClearBeforeRendering(true);+ }+}++bool HsQMLWindowInfo::needsBelowClear()+{+ Q_ASSERT(mImpl);+ if (mImpl->mBelowCount && !mImpl->mBelowClear) {+ mImpl->mBelowClear = true;+ return true;+ }+ return false;+}++void HsQMLWindowInfo::endFrame()+{+ Q_ASSERT(mImpl);+ mImpl->mBelowClear = false;+}++HsQMLCanvasBackEnd::HsQMLCanvasBackEnd(+ QQuickWindow* win,+ const HsQMLGLDelegate::CallbacksRef& cbs,+ HsQMLCanvas::DisplayMode mode)+ : mWindow(win)+ , mWinInfo(HsQMLWindowInfo::getWindowInfo(win))+ , mGLCallbacks(cbs)+ , mGL(NULL)+ , mStatus(HsQMLCanvas::Okay)+ , mDisplayMode(mode)+ , mItemWidth(0)+ , mItemHeight(0)+ , mTransformNode(NULL)+ , mCanvasWidth(0)+ , mCanvasHeight(0)+{+ if (HsQMLCanvas::Above == mDisplayMode) {+ QObject::connect(+ win, SIGNAL(afterRendering()),+ this, SLOT(doRendering()));+ }+ else {+ QObject::connect(+ win, SIGNAL(beforeRendering()),+ this, SLOT(doRendering()));++ if (HsQMLCanvas::Below == mDisplayMode) {+ mWinInfo.addBelow();+ QObject::connect(+ win, SIGNAL(frameSwapped()),+ this, SLOT(doEndFrame()));+ }+ }+}++HsQMLCanvasBackEnd::~HsQMLCanvasBackEnd()+{+ if (HsQMLCanvas::Below == mDisplayMode) {+ mWinInfo.removeBelow();+ }+}++void HsQMLCanvasBackEnd::setTransformNode(+ QSGTransformNode* tn, qreal w, qreal h)+{+ mTransformNode = tn;+ mItemWidth = w;+ mItemHeight = h;+}++QSGTexture* HsQMLCanvasBackEnd::updateFBO(qreal w, qreal h)+{+ if (HsQMLCanvas::Inline == mDisplayMode) {+ if (!mFBO || w != mCanvasWidth || h != mCanvasHeight) {+ mCanvasWidth = w;+ mCanvasHeight = h;+ QSize dims(qCeil(mCanvasWidth), qCeil(mCanvasHeight));+ mFBO.reset(new QOpenGLFramebufferObject(+ dims, QOpenGLFramebufferObject::Depth));+ mTexture.reset(mWindow->createTextureFromId(+ mFBO->texture(), dims, QQuickWindow::TextureHasAlphaChannel));+ }+ }+ else {+ mTexture.reset();+ mFBO.reset();+ }+ return mTexture.data();+}++HsQMLCanvas::Status HsQMLCanvasBackEnd::status() const+{+ return mStatus;+}++void HsQMLCanvasBackEnd::setStatus(HsQMLCanvas::Status status)+{+ bool change = mStatus != status;+ mStatus = status;+ if (change) {+ statusChanged(mStatus);+ }+}++void HsQMLCanvasBackEnd::doRendering()+{+ if (!mGL) {+ mGL = mWindow->openglContext();+ QObject::connect(+ mGL, SIGNAL(aboutToBeDestroyed()), this, SLOT(doCleanup()));+ HsQMLGLCanvasType ctype;+ QSurfaceFormat format = mGL->format();+ switch (format.renderableType()) {+ case QSurfaceFormat::OpenGL: ctype = HSQML_GL_DESKTOP; break;+ case QSurfaceFormat::OpenGLES: ctype = HSQML_GL_ES; break;+ default: setStatus(HsQMLCanvas::BadConfig); return;+ }+ mGLViewportFn = reinterpret_cast<GLViewportFn>(+ mGL->getProcAddress("glViewport"));+ mGLClearColorFn = reinterpret_cast<GLClearColorFn>(+ mGL->getProcAddress("glClearColor"));+ mGLClearFn = reinterpret_cast<GLClearFn>(+ mGL->getProcAddress("glClear"));+ if (!mGLViewportFn || !mGLClearColorFn || !mGLClearFn) {+ setStatus(HsQMLCanvas::BadProcs);+ return;+ }+ mGLCallbacks->mSetupCb(+ ctype, format.majorVersion(), format.minorVersion());+ }++ // Reset OpenGL state before rendering+#if QT_VERSION >= 0x050200+ mWindow->resetOpenGLState();+#else+#warning Resetting OpenGL state requires Qt 5.2 or later+#endif++ // Clear window if painting below the scenegraph+ if (mWinInfo.needsBelowClear()) {+ QColor bg = mWindow->color();+ mGLClearColorFn(bg.redF(), bg.greenF(), bg.blueF(), bg.alphaF());+ mGLClearFn(GL_COLOR_BUFFER_BIT);+ }++ // Setup prior to paint callback+ QMatrix4x4 matrix;+ bool inlineMode = HsQMLCanvas::Inline == mDisplayMode;+ if (inlineMode) {+ if (!mFBO->bind()) {+ setStatus(HsQMLCanvas::BadBind);+ return;+ }+ mGLViewportFn(0, 0, qCeil(mCanvasWidth), qCeil(mCanvasHeight));++ // Clear FBO to transparent+ mGLClearColorFn(0, 0, 0, 0);+ mGLClearFn(GL_COLOR_BUFFER_BIT);+ }+ else {+ // Calculate matrix for non-inline display modes+ QMatrix4x4 smatrix;+ QSGNode* node = mTransformNode;+ while (node) {+ if (QSGNode::TransformNodeType == node->type()) {+ QSGTransformNode* tnode = static_cast<QSGTransformNode*>(node);+ smatrix = tnode->matrix() * smatrix;+ }+ node = node->parent();+ }+ matrix.translate(-1, 1);+ matrix.scale(2.0f/mWindow->width(), -2.0f/mWindow->height());+ matrix *= smatrix;+ matrix.scale(mItemWidth/2.0f, mItemHeight/2.0f);+ matrix.translate(1, 1);++ mGLViewportFn(0, 0, mWindow->width(), mWindow->height());+ }++ setStatus(HsQMLCanvas::Okay);+ mGLCallbacks->mPaintCb(matrix.data(), mItemWidth, mItemHeight);++ if (inlineMode) {+ mFBO->release();+ }+}++void HsQMLCanvasBackEnd::doEndFrame()+{+ mWinInfo.endFrame();+}++void HsQMLCanvasBackEnd::doCleanup()+{+ if (mGL) {+ mGL->makeCurrent(mWindow);+ mGL = NULL;++ mTexture.reset();+ mFBO.reset();++ mGLCallbacks->mCleanupCb();+ }+}++void HsQMLCanvasBackEnd::doCleanupKill()+{+ doCleanup();+ delete this;+}++HsQMLCanvas::HsQMLCanvas(QQuickItem* parent)+ : QQuickItem(parent)+ , mWindow(NULL)+ , mBackEnd(NULL)+ , mStatus(Okay)+ , mFrontStatus(Okay)+ , mBackStatus(Okay)+ , mDisplayMode(Inline)+ , mCanvasWidth(0)+ , mCanvasWidthSet(false)+ , mCanvasHeight(0)+ , mCanvasHeightSet(false)+ , mLoadModel(false)+ , mValidModel(false)+{+ QObject::connect(+ this, SIGNAL(windowChanged(QQuickWindow*)),+ this, SLOT(doWindowChanged(QQuickWindow*)));+ setFlag(ItemHasContents, true);+}++HsQMLCanvas::~HsQMLCanvas()+{+ detachBackEnd();+}++void HsQMLCanvas::geometryChanged(const QRectF& rect, const QRectF&)+{+ if (!mCanvasWidthSet) {+ setCanvasWidth(rect.width(), false);+ }+ if (!mCanvasHeightSet) {+ setCanvasHeight(rect.height(), false);+ }+ update();+}++QSGNode* HsQMLCanvas::updatePaintNode(+ QSGNode* oldNode, UpdatePaintNodeData* paintData)+{+ // Window always needs repainting+ mWindow->update();++ // Lazily create new callbacks+ if (!mGLCallbacks) {+ mGLCallbacks = mDelegate.value<HsQMLGLDelegate>().makeCallbacks();+ mLoadModel = true;+ mValidModel = false;++ // Display nothing without a valid delegate+ if (!mGLCallbacks) {+ setStatus(BadDelegate);+ delete oldNode;+ return NULL;+ }+ }++ // Process model update+ if (mLoadModel) {+ mValidModel = mGLCallbacks->mSyncCb(+ reinterpret_cast<HsQMLJValHandle*>(&mModel));+ mLoadModel = false;+ }++ // Display nothing if there's no valid model+ if (!mValidModel) {+ setStatus(BadModel);+ detachBackEnd();+ delete oldNode;+ return NULL;+ }++ // Create back-end on the rendering thread+ if (!mBackEnd) {+ mBackEnd = new HsQMLCanvasBackEnd(mWindow, mGLCallbacks, mDisplayMode);++ // Monitor back-end's status+ QObject::connect(+ mBackEnd, SIGNAL(statusChanged(HsQMLCanvas::Status)),+ this, SLOT(doBackEndStatusChanged(HsQMLCanvas::Status)));+ setStatus(mBackEnd->status(), true);+ }+ setStatus(Okay);++ // Save pointer to transform node+ mBackEnd->setTransformNode(+ Inline != mDisplayMode ? paintData->transformNode : NULL,+ width(), height());++ // Produce texture node if needed+ if (QSGTexture* texture =+ mBackEnd->updateFBO(mCanvasWidth, mCanvasHeight)) {+ QSGSimpleTextureNode* n = static_cast<QSGSimpleTextureNode*>(oldNode);+ if (!n) {+ n = new QSGSimpleTextureNode();+ }+ n->setTexture(texture);+ n->setRect(0, 0, width(), height());+ return n;+ }++ delete oldNode;+ return NULL;+}++void HsQMLCanvas::detachBackEnd()+{+ if (mBackEnd) {+ // The back-end belongs to the rendering thread+ QMetaObject::invokeMethod(+ mBackEnd, "doCleanupKill", Qt::QueuedConnection);+ QObject::disconnect(mBackEnd, 0, this, 0);+ mBackEnd = NULL;+ mGLCallbacks.reset();+ }+}++HsQMLCanvas::DisplayMode HsQMLCanvas::displayMode() const+{+ return mDisplayMode;+}++void HsQMLCanvas::setDisplayMode(HsQMLCanvas::DisplayMode mode)+{+ bool change = mDisplayMode != mode;+ mDisplayMode = mode;+ if (change) {+ detachBackEnd();+ displayModeChanged();+ update();+ }+}++qreal HsQMLCanvas::canvasWidth() const+{+ return mCanvasWidth;+}++void HsQMLCanvas::setCanvasWidth(qreal w, bool set)+{+ bool change = mCanvasWidth != w;+ mCanvasWidth = w;+ mCanvasWidthSet |= set;+ if (change) {+ canvasWidthChanged();+ update();+ }+}++void HsQMLCanvas::unsetCanvasWidth()+{+ mCanvasWidthSet = false;+ setCanvasWidth(width(), false);+}++qreal HsQMLCanvas::canvasHeight() const+{+ return mCanvasHeight;+}++void HsQMLCanvas::setCanvasHeight(qreal h, bool set)+{+ bool change = mCanvasHeight != h;+ mCanvasHeight = h;+ mCanvasHeightSet |= set;+ if (change) {+ canvasHeightChanged();+ update();+ }+}++void HsQMLCanvas::unsetCanvasHeight()+{+ mCanvasHeightSet = false;+ setCanvasHeight(height(), false);+}++QVariant HsQMLCanvas::delegate() const+{+ return mDelegate;+}++void HsQMLCanvas::setDelegate(const QVariant& d)+{+ bool change = mDelegate != d;+ mDelegate = d;+ if (change) {+ detachBackEnd();+ delegateChanged();+ update();+ }+}++QJSValue HsQMLCanvas::model() const+{+ return mModel;+}++void HsQMLCanvas::setModel(const QJSValue& m)+{+ bool change = !mModel.strictlyEquals(m);+ mModel = m;+ if (change) {+ modelChanged();+ mLoadModel = true;+ update();+ }+}++HsQMLCanvas::Status HsQMLCanvas::status() const+{+ return mStatus;+}++void HsQMLCanvas::setStatus(Status status, bool backEnd)+{+ if (backEnd) {+ mBackStatus = status;+ }+ else {+ mFrontStatus = status;+ }+ Status newStatus = mFrontStatus == Okay ? mBackStatus : mFrontStatus;+ bool change = mStatus != newStatus;+ if (change) {+ statusChanged();+ }+}++void HsQMLCanvas::doWindowChanged(QQuickWindow* win)+{+ detachBackEnd();+ mWindow = win;+}++void HsQMLCanvas::doBackEndStatusChanged(Status status)+{+ setStatus(status, true);+}++HsQMLContextControl::HsQMLContextControl(QQuickItem* parent)+ : QQuickItem(parent)+ , mWindow(NULL)+ , mMajorVersion(-1)+ , mMinorVersion(-1)+ , mContextType(TypeUnset)+ , mContextProfile(ProfileUnset)+ , mDeprecatedFunctions(false)+ , mDeprecatedFunctionsSet(false)+ , mDepthBufferSize(0)+ , mStencilBufferSize(0)+ , mWhen(true)+ , mDefer(false)+ , mPending(false)+{+ QObject::connect(+ this, SIGNAL(windowChanged(QQuickWindow*)),+ this, SLOT(doWindowChanged(QQuickWindow*)));+}++HsQMLContextControl::~HsQMLContextControl()+{+}++int HsQMLContextControl::majorVersion()+{+ return mCurrent.majorVersion();+}++void HsQMLContextControl::setMajorVersion(int major)+{+ bool change = mMajorVersion != major;+ mMajorVersion = major;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetMajorVersion()+{+ setMajorVersion(-1);+}++int HsQMLContextControl::minorVersion()+{+ return mCurrent.minorVersion();+}++void HsQMLContextControl::setMinorVersion(int minor)+{+ bool change = mMinorVersion != minor;+ mMinorVersion = minor;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetMinorVersion()+{+ setMinorVersion(-1);+}++HsQMLContextControl::ContextType HsQMLContextControl::contextType()+{+ return static_cast<ContextType>(mCurrent.renderableType());+}++void HsQMLContextControl::setContextType(ContextType type)+{+ bool change = mContextType != type;+ mContextType = type;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetContextType()+{+ setContextType(TypeUnset);+}++HsQMLContextControl::ContextProfile HsQMLContextControl::contextProfile()+{+ return static_cast<ContextProfile>(mCurrent.profile());+}++void HsQMLContextControl::setContextProfile(ContextProfile profile)+{+ bool change = mContextProfile != profile;+ mContextProfile = profile;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetContextProfile()+{+ setContextProfile(ProfileUnset);+}++bool HsQMLContextControl::deprecatedFunctions()+{+ return mCurrent.testOption(QSurfaceFormat::DeprecatedFunctions);+}++void HsQMLContextControl::setDeprecatedFunctions(bool df, bool set)+{+ bool change = (mDeprecatedFunctionsSet != set) ||+ (mDeprecatedFunctionsSet && (mDeprecatedFunctions != df));+ mDeprecatedFunctions = df;+ mDeprecatedFunctionsSet = set;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetDeprecatedFunctions()+{+ setDeprecatedFunctions(false, false);+}++int HsQMLContextControl::depthBufferSize()+{+ return mCurrent.depthBufferSize();+}++void HsQMLContextControl::setDepthBufferSize(int size)+{+ bool change = mDepthBufferSize != size;+ mDepthBufferSize = size;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetDepthBufferSize()+{+ setDepthBufferSize(0);+}++int HsQMLContextControl::stencilBufferSize()+{+ return mCurrent.stencilBufferSize();+}++void HsQMLContextControl::setStencilBufferSize(int size)+{+ bool change = mStencilBufferSize != size;+ mStencilBufferSize = size;+ if (change) {+ controlContext();+ }+}++void HsQMLContextControl::unsetStencilBufferSize()+{+ setStencilBufferSize(0);+}++bool HsQMLContextControl::when()+{+ return mWhen;+}++void HsQMLContextControl::setWhen(bool when)+{+ mWhen = when;+ if (mPending && !mDefer && mWhen) {+ controlContext();+ }+}++void HsQMLContextControl::classBegin()+{+ mDefer = true;+}++void HsQMLContextControl::componentComplete()+{+ mDefer = false;+ if (mPending && mWhen) {+ controlContext();+ }+}++void HsQMLContextControl::doWindowChanged(QQuickWindow* win)+{+ if (mWindow) {+ QObject::disconnect(mWindow, 0, this, 0);+ }+ mWindow = win;+ if (mWindow) {+ QObject::connect(+ mWindow, SIGNAL(sceneGraphInitialized()),+ this, SLOT(doSceneGraphInit()));+ mOriginal = mWindow->requestedFormat();+ mCurrent = mWindow->openglContext() ?+ mWindow->openglContext()->format() : mWindow->format();+ }+ else {+ mOriginal = QSurfaceFormat();+ mCurrent = QSurfaceFormat();+ }+ contextChanged();++ if ((mMajorVersion >=0) || (mMinorVersion >= 0) ||+ (mContextType != TypeUnset) || (mContextProfile != ProfileUnset) ||+ !mDeprecatedFunctionsSet) {+ controlContext();+ }+}++void HsQMLContextControl::doSceneGraphInit()+{+ mCurrent = mWindow->openglContext()->format();+ contextChanged();+}++void HsQMLContextControl::controlContext()+{+ // Do nothing if no window+ if (!mWindow) {+ return;+ }++ // Do nothing if changes are being deferred+ if (mDefer || !mWhen) {+ mPending = true;+ return;+ }+ mPending = false;++ QSurfaceFormat fmt = mOriginal;+ if (mMajorVersion >= 0) {+ fmt.setMajorVersion(mMajorVersion);+ }+ if (mMinorVersion >= 0) {+ fmt.setMinorVersion(mMinorVersion);+ }+ if (mContextType >= 0) {+ fmt.setRenderableType(static_cast<QSurfaceFormat::RenderableType>(+ mContextType));+ }+ if (mContextProfile >= 0) {+ fmt.setProfile(static_cast<QSurfaceFormat::OpenGLContextProfile>(+ mContextProfile));+ }+ if (mDeprecatedFunctionsSet) {+#if QT_VERSION >= 0x050300+ fmt.setOption(QSurfaceFormat::DeprecatedFunctions,+ mDeprecatedFunctions);+#else+ if (mDeprecatedFunctions) {+ fmt.setOption(QSurfaceFormat::DeprecatedFunctions);+ }+#endif+ }+ fmt.setDepthBufferSize(qMax(fmt.depthBufferSize(), mDepthBufferSize));+ fmt.setStencilBufferSize(qMax(fmt.stencilBufferSize(), mStencilBufferSize));+ if (fmt == mWindow->requestedFormat()) {+ return;+ }+ mWindow->setFormat(fmt);++ // Recreate OpenGL context+ mWindow->setPersistentOpenGLContext(false);+ mWindow->setPersistentSceneGraph(false);+ bool visible = mWindow->isVisible();+ mWindow->destroy();+ mWindow->releaseResources();+ mWindow->setVisible(visible);+ mWindow->setPersistentOpenGLContext(true);+ mWindow->setPersistentSceneGraph(true);+}++HsQMLGLDelegateHandle* hsqml_create_gldelegate()+{+ return reinterpret_cast<HsQMLGLDelegateHandle*>(new HsQMLGLDelegate());+}++void hsqml_finalise_gldelegate_handle(+ HsQMLGLDelegateHandle* hndl)+{+ HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+ delete delegate;+}++void hsqml_gldelegate_setup(+ HsQMLGLDelegateHandle* hndl,+ HsQMLGLMakeCallbacksCb makeContextCb)+{+ HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+ delegate->setup(makeContextCb);+}++void hsqml_gldelegate_to_jval(+ HsQMLGLDelegateHandle* hndl,+ HsQMLJValHandle* jhndl)+{+ HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+ new((void*)jhndl) QJSValue(+ gManager->activeEngine()->declEngine()->toScriptValue(*delegate));+}++int hsqml_gldelegate_from_jval(+ HsQMLGLDelegateHandle* hndl,+ HsQMLJValHandle* jhndl)+{+ HsQMLGLDelegate* delegate = reinterpret_cast<HsQMLGLDelegate*>(hndl);+ QJSValue* value = reinterpret_cast<QJSValue*>(jhndl);+ *delegate = gManager->activeEngine()->declEngine()->+ fromScriptValue<HsQMLGLDelegate>(*value); + return delegate->isValid();+}
+ cbits/Canvas.h view
@@ -0,0 +1,295 @@+#ifndef HSQML_CANVAS_H+#define HSQML_CANVAS_H++#include <QtCore/QObject>+#include <QtCore/QExplicitlySharedDataPointer>+#include <QtCore/QMetaType>+#include <QtCore/QScopedPointer>+#include <QtCore/QSharedData>+#include <QtGui/qopengl.h>+#include <QtGui/QOpenGLContext>+#include <QtGui/QOpenGLFramebufferObject>+#include <QtQuick/QQuickItem>++#include "hsqml.h"++class QSGTexture;+class QSGTransformNode;+class QQuickWindow;+class HsQMLCanvasBackEnd;+class HsQMLWindowInfoImpl;++class HsQMLGLCallbacks : public QSharedData+{+public:+ HsQMLGLCallbacks(+ HsQMLGLSetupCb, HsQMLGLCleanupCb, HsQMLGLSyncCb, HsQMLGLPaintCb);+ ~HsQMLGLCallbacks();++ HsQMLGLSetupCb mSetupCb;+ HsQMLGLCleanupCb mCleanupCb;+ HsQMLGLSyncCb mSyncCb;+ HsQMLGLPaintCb mPaintCb;+};++class HsQMLGLDelegateImpl : public QSharedData+{+public:+ HsQMLGLDelegateImpl(HsQMLGLMakeCallbacksCb);+ ~HsQMLGLDelegateImpl();++ HsQMLGLMakeCallbacksCb mMakeCallbacksCb;+};++class HsQMLGLDelegate+{+public:+ HsQMLGLDelegate();+ ~HsQMLGLDelegate();+ void setup(HsQMLGLMakeCallbacksCb);+ bool isValid();+ typedef QExplicitlySharedDataPointer<HsQMLGLCallbacks> CallbacksRef;+ CallbacksRef makeCallbacks();++private:+ QExplicitlySharedDataPointer<HsQMLGLDelegateImpl> mImpl;+};++Q_DECLARE_METATYPE(HsQMLGLDelegate)++class HsQMLWindowInfoImpl : public QSharedData+{+public:+ HsQMLWindowInfoImpl(QQuickWindow*);+ +private:+ friend class HsQMLWindowInfo;+ QQuickWindow* mWin;+ int mBelowCount;+ bool mBelowClear;+};++class HsQMLWindowInfo+{+public:+ HsQMLWindowInfo();+ static HsQMLWindowInfo getWindowInfo(QQuickWindow*);+ void addBelow();+ void removeBelow();+ bool needsBelowClear();+ void endFrame();++private:+ QExplicitlySharedDataPointer<HsQMLWindowInfoImpl> mImpl;+};++Q_DECLARE_METATYPE(HsQMLWindowInfo)++class HsQMLCanvas : public QQuickItem+{+ Q_OBJECT+ Q_ENUMS(Status)+ Q_ENUMS(DisplayMode)+ Q_PROPERTY(DisplayMode displayMode READ displayMode WRITE setDisplayMode+ NOTIFY displayModeChanged)+ Q_PROPERTY(qreal canvasWidth READ canvasWidth WRITE setCanvasWidth+ RESET unsetCanvasWidth NOTIFY canvasWidthChanged)+ Q_PROPERTY(qreal canvasHeight READ canvasHeight WRITE setCanvasHeight+ RESET unsetCanvasHeight NOTIFY canvasHeightChanged)+ Q_PROPERTY(QVariant delegate READ delegate WRITE setDelegate+ NOTIFY delegateChanged)+ Q_PROPERTY(QJSValue model READ model WRITE setModel+ NOTIFY modelChanged)+ Q_PROPERTY(Status status READ status NOTIFY statusChanged)++public:+ enum Status {Okay, BadDelegate, BadModel, BadConfig, BadProcs, BadBind};+ enum DisplayMode {Above, Below, Inline};++ HsQMLCanvas(QQuickItem* = NULL);+ ~HsQMLCanvas();++private:+ Q_DISABLE_COPY(HsQMLCanvas);++ void geometryChanged(const QRectF&, const QRectF&) Q_DECL_OVERRIDE;+ QSGNode* updatePaintNode(QSGNode*, UpdatePaintNodeData*) Q_DECL_OVERRIDE;+ void detachBackEnd();+ DisplayMode displayMode() const;+ void setDisplayMode(DisplayMode);+ qreal canvasWidth() const;+ void setCanvasWidth(qreal, bool = true);+ void unsetCanvasWidth();+ qreal canvasHeight() const;+ void setCanvasHeight(qreal, bool = true);+ void unsetCanvasHeight();+ QVariant delegate() const;+ void setDelegate(const QVariant&);+ QJSValue model() const;+ void setModel(const QJSValue&);+ Status status() const;+ void setStatus(Status, bool = false);+ Q_SIGNAL void displayModeChanged();+ Q_SIGNAL void canvasWidthChanged();+ Q_SIGNAL void canvasHeightChanged();+ Q_SIGNAL void delegateChanged();+ Q_SIGNAL void modelChanged();+ Q_SIGNAL void statusChanged();+ Q_SLOT void doWindowChanged(QQuickWindow*);+ Q_SLOT void doBackEndStatusChanged(HsQMLCanvas::Status);++ QQuickWindow* mWindow;+ HsQMLCanvasBackEnd* mBackEnd;+ Status mStatus;+ Status mFrontStatus;+ Status mBackStatus;+ DisplayMode mDisplayMode;+ qreal mCanvasWidth;+ bool mCanvasWidthSet;+ qreal mCanvasHeight;+ bool mCanvasHeightSet;+ QVariant mDelegate;+ HsQMLGLDelegate::CallbacksRef mGLCallbacks;+ QJSValue mModel;+ bool mLoadModel;+ bool mValidModel;+};++class HsQMLCanvasBackEnd : public QObject+{+ Q_OBJECT++public:+ HsQMLCanvasBackEnd(+ QQuickWindow*,+ const HsQMLGLDelegate::CallbacksRef&,+ HsQMLCanvas::DisplayMode);+ ~HsQMLCanvasBackEnd();+ void setTransformNode(QSGTransformNode*, qreal, qreal);+ QSGTexture* updateFBO(qreal, qreal);+ HsQMLCanvas::Status status() const;++private:+ Q_DISABLE_COPY(HsQMLCanvasBackEnd)++ void setStatus(HsQMLCanvas::Status);+ Q_SLOT void doRendering();+ Q_SLOT void doEndFrame();+ Q_SLOT void doCleanup();+ Q_SLOT void doCleanupKill();+ Q_SIGNAL void statusChanged(HsQMLCanvas::Status);++ typedef void (*GLViewportFn)(GLint,GLint,GLsizei,GLsizei);+ typedef void (*GLClearColorFn)(GLclampf,GLclampf,GLclampf,GLclampf);+ typedef void (*GLClearFn)(GLbitfield);++ QQuickWindow* mWindow;+ HsQMLWindowInfo mWinInfo;+ HsQMLGLDelegate::CallbacksRef mGLCallbacks;+ QOpenGLContext* mGL;+ GLViewportFn mGLViewportFn;+ GLClearColorFn mGLClearColorFn;+ GLClearFn mGLClearFn;+ HsQMLCanvas::Status mStatus;+ HsQMLCanvas::DisplayMode mDisplayMode;+ qreal mItemWidth;+ qreal mItemHeight;+ QSGTransformNode* mTransformNode;+ qreal mCanvasWidth;+ qreal mCanvasHeight;+ QScopedPointer<QOpenGLFramebufferObject> mFBO;+ QScopedPointer<QSGTexture> mTexture;+};++class HsQMLContextControl : public QQuickItem+{+ Q_OBJECT+ Q_ENUMS(ContextType)+ Q_ENUMS(ContextProfile)+ Q_PROPERTY(int majorVersion READ majorVersion WRITE setMajorVersion+ RESET unsetMajorVersion NOTIFY contextChanged);+ Q_PROPERTY(int minorVersion READ minorVersion WRITE setMinorVersion+ RESET unsetMinorVersion NOTIFY contextChanged);+ Q_PROPERTY(ContextType contextType READ contextType WRITE setContextType+ RESET unsetContextType NOTIFY contextChanged);+ Q_PROPERTY(ContextProfile contextProfile READ contextProfile+ WRITE setContextProfile RESET unsetContextProfile+ NOTIFY contextChanged);+ Q_PROPERTY(bool deprecatedFunctions READ deprecatedFunctions+ WRITE setDeprecatedFunctions+ RESET unsetDeprecatedFunctions NOTIFY contextChanged);+ Q_PROPERTY(int depthBufferSize READ depthBufferSize+ WRITE setDepthBufferSize+ RESET unsetDepthBufferSize NOTIFY contextChanged);+ Q_PROPERTY(int stencilBufferSize READ stencilBufferSize+ WRITE setStencilBufferSize+ RESET unsetStencilBufferSize NOTIFY contextChanged);+ Q_PROPERTY(bool when READ when WRITE setWhen);++public:+ enum ContextType {+ TypeUnset = -1,+ UnknownType = QSurfaceFormat::DefaultRenderableType,+ OpenGL = QSurfaceFormat::OpenGL,+ OpenGLES = QSurfaceFormat::OpenGLES+ };+ enum ContextProfile {+ ProfileUnset = -1,+ NoProfile = QSurfaceFormat::NoProfile,+ CoreProfile = QSurfaceFormat::CoreProfile,+ CompatibilityProfile = QSurfaceFormat::CompatibilityProfile+ };++ HsQMLContextControl(QQuickItem* = NULL);+ ~HsQMLContextControl();++ Q_SIGNAL void contextChanged();+ int majorVersion();+ void setMajorVersion(int);+ void unsetMajorVersion();+ int minorVersion();+ void setMinorVersion(int);+ void unsetMinorVersion();+ ContextType contextType();+ void setContextType(ContextType);+ void unsetContextType();+ ContextProfile contextProfile();+ void setContextProfile(ContextProfile);+ void unsetContextProfile();+ bool deprecatedFunctions();+ void setDeprecatedFunctions(bool, bool = true);+ void unsetDeprecatedFunctions();+ int depthBufferSize();+ void setDepthBufferSize(int);+ void unsetDepthBufferSize();+ int stencilBufferSize();+ void setStencilBufferSize(int);+ void unsetStencilBufferSize();+ bool when();+ void setWhen(bool);++private:+ Q_DISABLE_COPY(HsQMLContextControl);++ Q_SLOT void doWindowChanged(QQuickWindow*);+ Q_SLOT void doSceneGraphInit();+ void classBegin();+ void componentComplete();+ void controlContext();+ QQuickWindow* mWindow;+ QSurfaceFormat mOriginal;+ QSurfaceFormat mCurrent;+ int mMajorVersion;+ int mMinorVersion;+ ContextType mContextType;+ ContextProfile mContextProfile;+ bool mDeprecatedFunctions;+ bool mDeprecatedFunctionsSet;+ int mDepthBufferSize;+ int mStencilBufferSize;+ bool mWhen;+ bool mDefer;+ bool mPending;+};++#endif //HSQML_CANVAS_H
+ cbits/Class.cpp view
@@ -0,0 +1,178 @@+#include <cstdlib>+#include <cstring>+#include <HsFFI.h>+#include <QtCore/QMetaObject>+#include <QtCore/QMetaType>+#include <QtCore/QString>++#include "hsqml.h"+#include "Class.h"+#include "Manager.h"++enum MDFields {+ MD_METHOD_COUNT = 4,+ MD_PROPERTY_COUNT = 6,+};++static const char* cRefSrcNames[] = {"Hndl", "Proxy"};++HsQMLClass::HsQMLClass(+ unsigned int* metaData,+ unsigned int* metaStrInfo,+ char* metaStrChar,+ HsStablePtr hsTypeRep,+ HsQMLUniformFunc* methods,+ HsQMLUniformFunc* properties)+ : mRefCount(0)+ , mMetaData(metaData)+ , mHsTypeRep(hsTypeRep)+ , mMethodCount(metaData[MD_METHOD_COUNT])+ , mPropertyCount(metaData[MD_PROPERTY_COUNT])+ , mMethods(methods)+ , mProperties(properties)+{+ // Create string data+ unsigned int strCount = metaStrInfo[0];+ unsigned int strLength = metaStrInfo[strCount];+ size_t arrayOff = strCount*sizeof(QByteArrayData);+ size_t arraySize = arrayOff+strLength;+ mMetaStrData.reset(new char[arraySize]);+ for (int i=0; i<strCount; i++) {+ int start = i > 0 ? metaStrInfo[i] : 0;+ int size = metaStrInfo[i+1] - start;+ int offset = arrayOff-(i*sizeof(QByteArrayData))+start;+ QByteArrayData data = {+ Q_REFCOUNT_INITIALIZE_STATIC, size-1, 0, 0, offset};+ std::memcpy(&mMetaStrData[i*sizeof(QByteArrayData)],+ &data, sizeof(QByteArrayData));+ }+ std::memcpy(&mMetaStrData[arrayOff], metaStrChar, strLength);++ // Create meta-object+ QMetaObject metaObj = {+ &QObject::staticMetaObject,+ reinterpret_cast<QByteArrayData*>(mMetaStrData.data()),+ mMetaData,+ 0,+ 0};+ mMetaObject = metaObj;++ // Add reference+ ref(Handle);++ gManager->updateCounter(HsQMLManager::ClassCount, 1);+}++HsQMLClass::~HsQMLClass()+{}++const char* HsQMLClass::name()+{+ return mMetaObject.className();+} ++HsStablePtr HsQMLClass::hsTypeRep()+{+ return mHsTypeRep;+}++int HsQMLClass::methodCount()+{+ return mMethodCount;+}++int HsQMLClass::propertyCount()+{+ return mPropertyCount;+}++const HsQMLUniformFunc* HsQMLClass::methods()+{+ return mMethods;+}++const HsQMLUniformFunc* HsQMLClass::properties()+{+ return mProperties;+}++const QMetaObject* HsQMLClass::metaObj()+{+ return &mMetaObject;+}++void HsQMLClass::ref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(1);++ HSQML_LOG(count == 0 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count ? "Ref" : "New", name(), cRefSrcNames[src], count+1));+}++void HsQMLClass::deref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(-1);++ HSQML_LOG(count == 1 ? 1 : 2,+ QString().sprintf("%s Class, name=%s, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count));++ if (count == 1) {+ 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()+{+ return gManager->updateCounter(HsQMLManager::ClassSerial, 1);+}++extern "C" HsQMLClassHandle* hsqml_create_class(+ unsigned int* metaData,+ unsigned int* metaStrInfo,+ char* metaStrChar,+ HsStablePtr hsTypeRep,+ HsQMLUniformFunc* methods,+ HsQMLUniformFunc* properties)+{+ HsQMLClass* klass = new HsQMLClass(+ metaData, metaStrInfo, metaStrChar, hsTypeRep, methods, properties);+ return (HsQMLClassHandle*)klass;+}++extern "C" void hsqml_finalise_class_handle(+ HsQMLClassHandle* hndl)+{+ HsQMLClass* klass = (HsQMLClass*)hndl;+ klass->deref(HsQMLClass::Handle);+}
+ cbits/Class.h view
@@ -0,0 +1,41 @@+#ifndef HSQML_CLASS_H+#define HSQML_CLASS_H++#include <QtCore/QObject>+#include <QtCore/QAtomicInt>+#include <QtCore/QScopedArrayPointer>++#include "hsqml.h"++class HsQMLClass+{+public:+ HsQMLClass(+ unsigned int*, unsigned int*, char*,+ HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*);+ ~HsQMLClass();+ const char* name();+ HsStablePtr hsTypeRep();+ int methodCount();+ int propertyCount();+ const HsQMLUniformFunc* methods();+ const HsQMLUniformFunc* properties();+ const QMetaObject* metaObj();+ void destroy();+ enum RefSrc {Handle, ObjProxy};+ void ref(RefSrc);+ void deref(RefSrc);++private:+ QAtomicInt mRefCount;+ unsigned int* mMetaData;+ QScopedArrayPointer<char> mMetaStrData;+ HsStablePtr mHsTypeRep;+ int mMethodCount;+ int mPropertyCount;+ HsQMLUniformFunc* mMethods;+ HsQMLUniformFunc* mProperties;+ QMetaObject mMetaObject;+};++#endif /*HSQML_CLASS_H*/
+ 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
@@ -0,0 +1,241 @@+#include <QtQuick/QQuickItem>+#include <QtQuick/QQuickWindow>++#include "Manager.h"+#include "Engine.h"+#include "Object.h"++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()),+ this, SLOT(deleteLater()));+ QObject::connect(+ &mComponent, SIGNAL(statusChanged(QQmlComponent::Status)),+ this, SLOT(componentStatus(QQmlComponent::Status)));++ // Obtain, re-parent, and set QML global object+ 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());+ mEngine.setPluginPathList(+ QStringList(config->pluginPaths) << mEngine.pluginPathList());++ // Load document+ mComponent.loadUrl(QUrl(config->initialURL));+}++HsQMLEngine::~HsQMLEngine()+{+ // Call stop callback+ mStopCb();+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mStopCb));++ // 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)+{+ if (QEvent::Close == ev->type()) {+ deleteLater();+ }+ return false;+}++QQmlEngine* HsQMLEngine::declEngine()+{+ return &mEngine;+}++void HsQMLEngine::componentStatus(QQmlComponent::Status status)+{+ switch (status) {+ case QQmlComponent::Ready: {+ QObject* obj = mComponent.create();+ // 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();+ mResources << win;+ item->setParentItem(win->contentItem());+ int width = item->width();+ int height = item->height();+ if (width < 1 || height < 1) {+ width = item->implicitWidth();+ height = item->implicitHeight();+ }+ win->setWidth(width);+ win->setHeight(height);+ win->contentItem()->setWidth(width);+ win->contentItem()->setHeight(height);+ win->setTitle("HsQML Window");+ win->show();+ }+ if (win) {+ win->installEventFilter(this);+ mEngine.setIncubationController(win->incubationController());+ }+ break;}+ case QQmlComponent::Error: {+ QList<QQmlError> errs = mComponent.errors();+ for (QList<QQmlError>::iterator it = errs.begin();+ it != errs.end(); ++it) {+ HSQML_LOG(0, it->toString());+ }+ deleteLater();+ break;}+ default: break;+ }+}++extern "C" HsQMLEngineHandle* hsqml_create_engine(+ HsQMLObjectHandle* contextObject,+ HsQMLStringHandle* initialURL,+ HsQMLStringHandle** importPaths,+ HsQMLStringHandle** pluginPaths,+ HsQMLTrivialCb stopCb)+{+ 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);+ }+ for (QString** p = reinterpret_cast<QString**>(pluginPaths); *p; p++) {+ config->pluginPaths.push_back(**p);+ }+ config->stopCb = stopCb;++ 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
@@ -0,0 +1,81 @@+#ifndef HSQML_ENGINE_H+#define HSQML_ENGINE_H++#include <QtCore/QEvent>+#include <QtCore/QString>+#include <QtCore/QStringList>+#include <QtCore/QUrl>+#include <QtQml/QQmlEngine>+#include <QtQml/QQmlContext>+#include <QtQml/QQmlComponent>++#include "hsqml.h"++class HsQMLEngine;+class HsQMLObjectProxy;+class HsQMLWindow;++class HsQMLEngineProxy+{+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+{+ Q_OBJECT++public:+ HsQMLEngine(const HsQMLEngineCreateEvent*, QObject* = NULL);+ ~HsQMLEngine();+ bool eventFilter(QObject*, QEvent*);+ QQmlEngine* declEngine();++private:+ Q_DISABLE_COPY(HsQMLEngine)++ Q_SLOT void componentStatus(QQmlComponent::Status);+ HsQMLEngineProxy* mProxy;+ QQmlEngine mEngine;+ QQmlComponent mComponent;+ QList<HsQMLObjectProxy*> mGlobals;+ QList<QObject*> mResources;+ HsQMLTrivialCb mStopCb;+};++#endif /*HSQML_ENGINE_H*/
+ cbits/HighDpiScaling.cpp view
@@ -0,0 +1,5 @@+#include "QtGui/QGuiApplication"++extern "C" void hsqml_enable_high_dpi_scaling() {+ QGuiApplication::setAttribute(Qt::AA_EnableHighDpiScaling);+}
+ cbits/HighDpiScaling.h view
@@ -0,0 +1,9 @@+#ifdef __cplusplus+extern "C" {+#endif++void hsqml_enable_high_dpi_scaling();++#ifdef __cplusplus+}+#endif
− cbits/HsQMLClass.cpp
@@ -1,146 +0,0 @@-#include <cstdlib>-#include <HsFFI.h>-#include <QtCore/QMetaObject>-#include <QtCore/QMetaType>-#include <QtCore/QString>--#include "hsqml.h"-#include "HsQMLClass.h"-#include "HsQMLManager.h"--enum MDFields {- MD_METHOD_COUNT = 4,- MD_PROPERTY_COUNT = 6,-};--static const char* cRefSrcNames[] = {"Hndl", "Proxy"};--HsQMLClass::HsQMLClass(- unsigned int* metaData,- char* metaStrData,- HsStablePtr hsTypeRep,- HsQMLUniformFunc* methods,- HsQMLUniformFunc* properties)- : mRefCount(0)- , mMetaData(metaData)- , mMetaStrData(metaStrData)- , mHsTypeRep(hsTypeRep)- , mMethodCount(metaData[MD_METHOD_COUNT])- , mPropertyCount(metaData[MD_PROPERTY_COUNT])- , mMethods(methods)- , mProperties(properties)-{- // Create meta-object- QMetaObject tmp = {- &QObject::staticMetaObject,- mMetaStrData,- mMetaData,- 0};- mMetaObject = new QMetaObject(tmp);-- // Add reference- ref(Handle);-- gManager->updateCounter(HsQMLManager::ClassCount, 1);-}--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(mMetaStrData);- std::free(mMethods);- std::free(mProperties);- delete mMetaObject;-- gManager->updateCounter(HsQMLManager::ClassCount, -1);-}--const char* HsQMLClass::name()-{- return mMetaObject->className();-} --HsStablePtr HsQMLClass::hsTypeRep()-{- return mHsTypeRep;-}--int HsQMLClass::methodCount()-{- return mMethodCount;-}--int HsQMLClass::propertyCount()-{- return mPropertyCount;-}--const HsQMLUniformFunc* HsQMLClass::methods()-{- return mMethods;-}--const HsQMLUniformFunc* HsQMLClass::properties()-{- return mProperties;-}--const QMetaObject* HsQMLClass::metaObj()-{- return mMetaObject;-}--void HsQMLClass::ref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(1);-- HSQML_LOG(count == 0 ? 1 : 2,- QString().sprintf("%s Class, name=%s, src=%s, count=%d.",- count ? "Ref" : "New", name(), cRefSrcNames[src], count+1));-}--void HsQMLClass::deref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(-1);-- HSQML_LOG(count == 1 ? 1 : 2,- QString().sprintf("%s Class, name=%s, src=%s, count=%d.",- count > 1 ? "Deref" : "Delete", name(), cRefSrcNames[src], count));-- if (count == 1) {- delete this;- }-}--extern "C" int hsqml_get_next_class_id()-{- return gManager->updateCounter(HsQMLManager::ClassSerial, 1);-}--extern "C" HsQMLClassHandle* hsqml_create_class(- unsigned int* metaData,- char* metaStrData,- HsStablePtr hsTypeRep,- HsQMLUniformFunc* methods,- HsQMLUniformFunc* properties)-{- HsQMLClass* klass = new HsQMLClass(- metaData, metaStrData, hsTypeRep, methods, properties);- return (HsQMLClassHandle*)klass;-}--extern "C" void hsqml_finalise_class_handle(- HsQMLClassHandle* hndl)-{- HsQMLClass* klass = (HsQMLClass*)hndl;- klass->deref(HsQMLClass::Handle);-}
− cbits/HsQMLClass.h
@@ -1,39 +0,0 @@-#ifndef HSQML_CLASS_H-#define HSQML_CLASS_H--#include <QtCore/QObject>-#include <QtCore/QAtomicInt>--#include "hsqml.h"--class HsQMLClass-{-public:- HsQMLClass(- unsigned int*, char*, HsStablePtr,- HsQMLUniformFunc*, HsQMLUniformFunc*);- ~HsQMLClass();- const char* name();- HsStablePtr hsTypeRep();- int methodCount();- int propertyCount();- const HsQMLUniformFunc* methods();- const HsQMLUniformFunc* properties();- const QMetaObject* metaObj();- enum RefSrc {Handle, ObjProxy};- void ref(RefSrc);- void deref(RefSrc);--private:- QAtomicInt mRefCount;- unsigned int* mMetaData;- char* mMetaStrData;- HsStablePtr mHsTypeRep;- int mMethodCount;- int mPropertyCount;- HsQMLUniformFunc* mMethods;- HsQMLUniformFunc* mProperties;- QMetaObject* mMetaObject;-};--#endif /*HSQML_CLASS_H*/
− cbits/HsQMLEngine.cpp
@@ -1,95 +0,0 @@-#include "HsQMLManager.h"-#include "HsQMLEngine.h"-#include "HsQMLObject.h"-#include "HsQMLWindow.h"--HsQMLScriptHack::HsQMLScriptHack(QDeclarativeEngine* declEng)- : mEngine(NULL)-{- QDeclarativeEngine::setObjectOwnership(- this, QDeclarativeEngine::CppOwnership);- QDeclarativeExpression expr(declEng->rootContext(), this, "hack(self());");- expr.evaluate();- Q_ASSERT(!expr.hasError());-}--QObject* HsQMLScriptHack::self()-{- return this;-}--void HsQMLScriptHack::hack(QScriptValue value)-{- mEngine = value.engine();-}--QScriptEngine* HsQMLScriptHack::scriptEngine() const-{- return mEngine;-}--HsQMLEngine::HsQMLEngine(const HsQMLEngineConfig& config)- : mScriptEngine(HsQMLScriptHack(&mDeclEngine).scriptEngine())- , mStopCb(config.stopCb)-{- // Obtain, re-parent, and set QML global object- if (config.contextObject) {- mContextObj.reset(config.contextObject->object(this));- mDeclEngine.rootContext()->setContextObject(mContextObj.data());- }-- // Create window- HsQMLWindow* win = new HsQMLWindow(this);- win->setParent(this);- win->setSource(config.initialURL);- win->setVisible(config.showWindow);- if (config.setWindowTitle) {- win->setTitle(config.windowTitle);- }-}--HsQMLEngine::~HsQMLEngine()-{- // Call stop callback- mStopCb();- gManager->freeFun(reinterpret_cast<HsFunPtr>(mStopCb));-}--void HsQMLEngine::childEvent(QChildEvent* ev)-{- if (ev->removed() && children().size() == 0) {- deleteLater();- }-}--QDeclarativeEngine* HsQMLEngine::declEngine()-{- return &mDeclEngine;-}--QScriptEngine* HsQMLEngine::scriptEngine()-{- return mScriptEngine;-}--extern "C" void hsqml_create_engine(- HsQMLObjectHandle* contextObject,- HsQMLUrlHandle* initialURL,- int showWindow,- int setWindowTitle,- HsQMLStringHandle* windowTitle,- HsQMLTrivialCb stopCb)-{- HsQMLEngineConfig config;- config.contextObject = reinterpret_cast<HsQMLObjectProxy*>(contextObject);- config.initialURL = *reinterpret_cast<QUrl*>(initialURL);- config.showWindow = static_cast<bool>(showWindow);- if (setWindowTitle) {- config.setWindowTitle = true;- config.windowTitle = *reinterpret_cast<QString*>(windowTitle);- }- config.stopCb = stopCb;-- Q_ASSERT (gManager);- gManager->createEngine(config);-}
− cbits/HsQMLEngine.h
@@ -1,68 +0,0 @@-#ifndef HSQML_ENGINE_H-#define HSQML_ENGINE_H--#include <QtCore/QScopedPointer>-#include <QtCore/QString>-#include <QtCore/QUrl>-#include <QtScript/QScriptEngine>-#include <QtScript/QScriptValue>-#include <QtDeclarative/QDeclarativeEngine>-#include <QtDeclarative/QDeclarativeExpression>--#include "hsqml.h"--class HsQMLObjectProxy;-class HsQMLWindow;--struct HsQMLEngineConfig-{- HsQMLEngineConfig()- : contextObject(NULL)- , showWindow(false)- , setWindowTitle(false)- , stopCb(NULL)- {}-- HsQMLObjectProxy* contextObject;- QUrl initialURL;- bool showWindow;- bool setWindowTitle;- QString windowTitle;- HsQMLTrivialCb stopCb;-};--class HsQMLScriptHack : public QObject-{- Q_OBJECT--public:- HsQMLScriptHack(QDeclarativeEngine*);- Q_INVOKABLE virtual QObject* self();- Q_INVOKABLE virtual void hack(QScriptValue);- QScriptEngine* scriptEngine() const;--private:- QScriptEngine* mEngine;-};--class HsQMLEngine : public QObject-{- Q_OBJECT--public:- HsQMLEngine(const HsQMLEngineConfig&);- ~HsQMLEngine();- virtual void childEvent(QChildEvent*);- QDeclarativeEngine* declEngine();- QScriptEngine* scriptEngine();--private:- Q_DISABLE_COPY(HsQMLEngine)-- QDeclarativeEngine mDeclEngine;- QScriptEngine* mScriptEngine;- QScopedPointer<QObject> mContextObj;- HsQMLTrivialCb mStopCb;-};--#endif /*HSQML_ENGINE_H*/
− cbits/HsQMLIntrinsics.cpp
@@ -1,77 +0,0 @@-#include <cstdlib>-#include <cstring>--#include <QtCore/QString>-#include <QtCore/QUrl>--#include "hsqml.h"--/* String */-extern "C" size_t hsqml_get_string_size()-{- return sizeof(QString);-}--extern "C" void hsqml_init_string(HsQMLStringHandle* hndl)-{- new((void*)hndl) QString();-}--extern "C" void hsqml_deinit_string(HsQMLStringHandle* hndl)-{- QString* string = (QString*)hndl;- string->~QString();-}--extern "C" UTF16* hsqml_marshal_string(- int bufLen, HsQMLStringHandle* hndl)-{- QString* string = (QString*)hndl;- string->resize(bufLen);- return reinterpret_cast<UTF16*>(string->data());-}--extern "C" int hsqml_unmarshal_string(- HsQMLStringHandle* hndl, UTF16** bufPtr)-{- QString* string = (QString*)hndl;- *bufPtr = reinterpret_cast<UTF16*>(string->data());- return string->length();-}--/* URL */-extern "C" size_t hsqml_get_url_size()-{- return sizeof(QUrl);-}--extern "C" void hsqml_init_url(HsQMLUrlHandle* hndl)-{- new((void*)hndl) QUrl();-}--extern "C" void hsqml_deinit_url(HsQMLUrlHandle* hndl)-{- QUrl* url = (QUrl*)hndl;- url->~QUrl();-}--extern "C" void hsqml_marshal_url(- char* buf, int bufLen, HsQMLUrlHandle* hndl)-{- QUrl* url = (QUrl*)hndl;- QByteArray cstr(buf, bufLen);- url->setEncodedUrl(cstr, QUrl::StrictMode);-}--extern "C" int hsqml_unmarshal_url(- HsQMLUrlHandle* hndl, char** bufPtr)-{- QUrl* url = (QUrl*)hndl;- QByteArray cstr = url->toEncoded();- int bufLen = cstr.length();- char* buf = reinterpret_cast<char*>(malloc(bufLen));- memcpy(buf, cstr.data(), bufLen);- *bufPtr = buf;- return bufLen;-}
− cbits/HsQMLManager.cpp
@@ -1,325 +0,0 @@-#include <iostream>-#include <cstdlib>-#include <QtCore/QBasicTimer>-#include <QtCore/QMetaType>-#include <QtCore/QMutexLocker>-#include <QtCore/QThread>-#ifdef Q_WS_MAC-#include <pthread.h>-#endif--#include "HsQMLManager.h"-#include "HsQMLObject.h"--static const char* cCounterNames[] = {- "ClassCounter",- "ObjectCounter",- "QObjectCounter",- "ClassSerial",- "ObjectSerial"-};--extern "C" void hsqml_dump_counters()-{- Q_ASSERT (gManager);- if (gManager->checkLogLevel(1)) {- for (int i=0; i<HsQMLManager::TotalCounters; i++) {- gManager->log(QString().sprintf("%s = %d.",- cCounterNames[i], gManager->updateCounter(- static_cast<HsQMLManager::CounterId>(i), 0)));- }- }-}--QAtomicPointer<HsQMLManager> gManager;--HsQMLManager::HsQMLManager(- void (*freeFun)(HsFunPtr),- void (*freeStable)(HsStablePtr))- : mLogLevel(0)- , mAtExit(false)- , mFreeFun(freeFun)- , mFreeStable(freeStable)- , mApp(NULL)- , mLock(QMutex::Recursive)- , mRunning(false)- , mRunCount(0)- , mStartCb(NULL)- , mJobsCb(NULL)- , mYieldCb(NULL)- , mActiveEngine(NULL)-{- qRegisterMetaType<HsQMLEngineConfig>("HsQMLEngineConfig");-- const char* env = std::getenv("HSQML_DEBUG_LOG_LEVEL");- if (env) {- setLogLevel(QString(env).toInt());- }-}--void HsQMLManager::setLogLevel(int ll)-{- mLogLevel = ll;- if (ll > 0 && !mAtExit) {- if (atexit(&hsqml_dump_counters) == 0) {- mAtExit = true;- }- else {- log("Failed to register callback with atexit().");- }- }-}--bool HsQMLManager::checkLogLevel(int ll)-{- return mLogLevel >= ll;-}--void HsQMLManager::log(const QString& msg)-{- std::cerr << "HsQML: " << msg.toStdString() << std::endl;-}--int HsQMLManager::updateCounter(CounterId id, int delta)-{- return mCounters[id].fetchAndAddRelaxed(delta);-}--void HsQMLManager::freeFun(HsFunPtr funPtr)-{- mFreeFun(funPtr);-}--void HsQMLManager::freeStable(HsStablePtr stablePtr)-{- mFreeStable(stablePtr);-}--bool HsQMLManager::isEventThread()-{- return mApp && mApp->thread() == QThread::currentThread();-}--HsQMLManager::EventLoopStatus HsQMLManager::runEventLoop(- HsQMLTrivialCb startCb,- HsQMLTrivialCb jobsCb,- HsQMLTrivialCb yieldCb)-{- QMutexLocker locker(&mLock);-- // Check if already running- if (mRunning) {- return HSQML_EVLOOP_ALREADY_RUNNING;- }-- // Check if event loop bound to a different thread- if (mApp && !isEventThread()) {- return HSQML_EVLOOP_WRONG_THREAD;- }--#ifdef Q_WS_MAC- if (!pthread_main_np()) {- // Cocoa can only be run on the primordial thread and exec() doesn't- // check this.- return HSQML_EVLOOP_WRONG_THREAD;- }-#endif-- // Create application object- if (!mApp) {- mApp = new HsQMLManagerApp();- }-- // Save callbacks- mStartCb = startCb;- mJobsCb = jobsCb;- mYieldCb = yieldCb;-- // Setup events- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::StartedLoopEvent),- Qt::HighEventPriority);- QBasicTimer idleTimer;- if (yieldCb) {- idleTimer.start(0, mApp);- }-- // Run loop- int ret = mApp->exec();-- // Remove redundant events- QCoreApplication::removePostedEvents(- mApp, HsQMLManagerApp::RemoveGCLockEvent);-- // Cleanup callbacks- freeFun(startCb);- mStartCb = NULL;- freeFun(jobsCb);- mJobsCb = NULL;- if (yieldCb) {- freeFun(yieldCb);- mYieldCb = NULL;- }-- // Return- if (ret == 0) {- return HSQML_EVLOOP_OK;- }- else {- QCoreApplication::removePostedEvents(- mApp, HsQMLManagerApp::StartedLoopEvent);- return HSQML_EVLOOP_OTHER_ERROR;- }-}--HsQMLManager::EventLoopStatus HsQMLManager::requireEventLoop()-{- QMutexLocker locker(&mLock);- if (mRunCount > 0) {- mRunCount++;- return HSQML_EVLOOP_OK;- }- else {- return HSQML_EVLOOP_NOT_RUNNING;- }-}--void HsQMLManager::releaseEventLoop()-{- QMutexLocker locker(&mLock);- if (--mRunCount == 0) {- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::StopLoopEvent),- Qt::LowEventPriority);- }-}--void HsQMLManager::notifyJobs()-{- QMutexLocker locker(&mLock);- if (mRunCount > 0) {- QCoreApplication::postEvent(- mApp, new QEvent(HsQMLManagerApp::PendingJobsEvent));- }-}--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);- mActiveEngine = engine;-}--HsQMLEngine* HsQMLManager::activeEngine()-{- return mActiveEngine;-}--void HsQMLManager::postObjectEvent(HsQMLObjectEvent* ev)-{- QCoreApplication::postEvent(mApp, ev);-}--HsQMLManagerApp::HsQMLManagerApp()- : mArgC(1)- , mArg0(0)- , mArgV(&mArg0)- , mApp(mArgC, &mArgV)-{- mApp.setQuitOnLastWindowClosed(false);-}--HsQMLManagerApp::~HsQMLManagerApp()-{}--void HsQMLManagerApp::customEvent(QEvent* ev)-{- switch (ev->type()) {- case HsQMLManagerApp::StartedLoopEvent: {- gManager->mRunning = true;- gManager->mRunCount++;- gManager->mLock.unlock();- gManager->mStartCb();- gManager->mJobsCb();- break;}- case HsQMLManagerApp::StopLoopEvent: {- gManager->mLock.lock();- const QObjectList& cs = gManager->mApp->children();- while (!cs.empty()) {- delete cs.front();- }- gManager->mRunning = false;- gManager->mApp->mApp.quit();- break;}- case HsQMLManagerApp::PendingJobsEvent: {- gManager->mJobsCb();- break;}- case HsQMLManagerApp::RemoveGCLockEvent: {- static_cast<HsQMLObjectEvent*>(ev)->process();- break;}- }-}--void HsQMLManagerApp::timerEvent(QTimerEvent*)-{- Q_ASSERT(gManager->mYieldCb);- gManager->mYieldCb();-}--void HsQMLManagerApp::createEngine(HsQMLEngineConfig config)-{- HsQMLEngine* engine = new HsQMLEngine(config);- engine->setParent(this);-}--int HsQMLManagerApp::exec()-{- return mApp.exec();-}--extern "C" void hsqml_init(- void (*freeFun)(HsFunPtr),- void (*freeStable)(HsStablePtr))-{- if (gManager == NULL) {- HsQMLManager* manager = new HsQMLManager(freeFun, freeStable);- if (!gManager.testAndSetOrdered(NULL, manager)) {- delete manager;- }- }-}--extern "C" HsQMLEventLoopStatus hsqml_evloop_run(- HsQMLTrivialCb startCb,- HsQMLTrivialCb jobsCb,- HsQMLTrivialCb yieldCb)-{- return gManager->runEventLoop(startCb, jobsCb, yieldCb);-}--extern "C" HsQMLEventLoopStatus hsqml_evloop_require()-{- return gManager->requireEventLoop();-}--extern "C" void hsqml_evloop_release()-{- gManager->releaseEventLoop();-}--extern "C" void hsqml_evloop_notify_jobs()-{- gManager->notifyJobs();-}--extern "C" void hsqml_set_debug_loglevel(int ll)-{- Q_ASSERT (gManager);- gManager->setLogLevel(ll);-}
− cbits/HsQMLManager.h
@@ -1,109 +0,0 @@-#ifndef HSQML_MANAGER_H-#define HSQML_MANAGER_H--#include <QtCore/QAtomicPointer>-#include <QtCore/QAtomicInt>-#include <QtCore/QMutex>-#include <QtCore/QString>-#include <QtGui/QApplication>--#include "hsqml.h"-#include "HsQMLEngine.h"--#define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg)--class HsQMLManagerApp;-class HsQMLObjectEvent;--class HsQMLManager-{-public:- enum CounterId {- ClassCount,- ObjectCount,- QObjectCount,- ClassSerial,- ObjectSerial,- TotalCounters- }; -- HsQMLManager(- void (*)(HsFunPtr),- void (*)(HsStablePtr));- void setLogLevel(int);- bool checkLogLevel(int);- void log(const QString&);- int updateCounter(CounterId, int);- void freeFun(HsFunPtr);- void freeStable(HsStablePtr);- bool isEventThread();- typedef HsQMLEventLoopStatus EventLoopStatus;- EventLoopStatus runEventLoop(- HsQMLTrivialCb, HsQMLTrivialCb, HsQMLTrivialCb);- EventLoopStatus requireEventLoop();- void releaseEventLoop();- void notifyJobs();- void createEngine(const HsQMLEngineConfig&);- void setActiveEngine(HsQMLEngine*);- HsQMLEngine* activeEngine();- void postObjectEvent(HsQMLObjectEvent*);--private:- friend class HsQMLManagerApp;- Q_DISABLE_COPY(HsQMLManager)-- int mLogLevel;- QAtomicInt mCounters[TotalCounters];- bool mAtExit;- void (*mFreeFun)(HsFunPtr);- void (*mFreeStable)(HsStablePtr);- HsQMLManagerApp* mApp;- QMutex mLock;- bool mRunning;- int mRunCount;- HsQMLTrivialCb mStartCb;- HsQMLTrivialCb mJobsCb;- HsQMLTrivialCb mYieldCb;- HsQMLEngine* mActiveEngine;-};--class HsQMLManagerApp : public QObject-{- Q_OBJECT--public:- HsQMLManagerApp();- virtual ~HsQMLManagerApp();- virtual void customEvent(QEvent*);- virtual void timerEvent(QTimerEvent*);- Q_SLOT void createEngine(HsQMLEngineConfig);- int exec();-- enum CustomEventIndicies {- StartedLoopEventIndex,- StopLoopEventIndex,- PendingJobsEventIndex,- RemoveGCLockEventIndex- };-- static const QEvent::Type StartedLoopEvent =- static_cast<QEvent::Type>(QEvent::User+StartedLoopEventIndex);- static const QEvent::Type StopLoopEvent =- static_cast<QEvent::Type>(QEvent::User+StopLoopEventIndex);- static const QEvent::Type PendingJobsEvent =- static_cast<QEvent::Type>(QEvent::User+PendingJobsEventIndex);- static const QEvent::Type RemoveGCLockEvent =- static_cast<QEvent::Type>(QEvent::User+RemoveGCLockEventIndex);--private:- Q_DISABLE_COPY(HsQMLManagerApp)-- int mArgC;- char mArg0;- char* mArgV;- QApplication mApp;-};--extern QAtomicPointer<HsQMLManager> gManager;--#endif /*HSQML_MANAGER_H*/
− cbits/HsQMLObject.cpp
@@ -1,329 +0,0 @@-#include <HsFFI.h>-#include <QtCore/QString>-#include <QtDeclarative/QDeclarativeEngine>--#include "HsQMLObject.h"-#include "HsQMLClass.h"-#include "HsQMLManager.h"--static const char* cRefSrcNames[] = {"Hndl", "Obj", "Event"};--HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)- : mHaskell(haskell)- , mKlass(klass)- , mSerial(gManager->updateCounter(HsQMLManager::ObjectSerial, 1))- , mObject(NULL)- , mRefCount(0)-{- ref(Handle);- mKlass->ref(HsQMLClass::ObjProxy);- gManager->updateCounter(HsQMLManager::ObjectCount, 1);-}--HsQMLObjectProxy::~HsQMLObjectProxy()-{- mKlass->deref(HsQMLClass::ObjProxy);- gManager->updateCounter(HsQMLManager::ObjectCount, -1);-}--HsStablePtr HsQMLObjectProxy::haskell() const-{- return mHaskell;-}--HsQMLClass* HsQMLObjectProxy::klass() const-{- return mKlass;-}--HsQMLObject* HsQMLObjectProxy::object(HsQMLEngine* engine)-{- Q_ASSERT(gManager->isEventThread());- Q_ASSERT(engine);- if (!mObject) {- mObject = new HsQMLObject(this, engine);- tryGCLock();-- HSQML_LOG(5,- QString().sprintf("New QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }- return mObject;-}--void HsQMLObjectProxy::clearObject()-{- Q_ASSERT(gManager->isEventThread());-- mObject = NULL;-- HSQML_LOG(5,- QString().sprintf("Release QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));-}--void HsQMLObjectProxy::tryGCLock()-{- Q_ASSERT(gManager->isEventThread());-- if (mObject && mHndlCount > 0 && !mObject->isGCLocked()) {- mObject->setGCLock();-- HSQML_LOG(5,- QString().sprintf("Lock QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }-}--void HsQMLObjectProxy::removeGCLock()-{- Q_ASSERT(gManager->isEventThread());-- if (mObject && mHndlCount == 0 && mObject->isGCLocked()) {- mObject->clearGCLock();-- HSQML_LOG(5,- QString().sprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",- mKlass->name(), mSerial, mObject));- }-}--HsQMLEngine* HsQMLObjectProxy::engine() const-{- if (mObject != NULL) {- return mObject->engine();- }- return NULL;-}--void HsQMLObjectProxy::ref(RefSrc src)-{- int count = mRefCount.fetchAndAddOrdered(1);-- HSQML_LOG(count == 0 ? 3 : 4,- QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",- count ? "Ref" : "New", mKlass->name(),- mSerial, cRefSrcNames[src], count+1));-- if (src == Handle) {- mHndlCount.fetchAndAddOrdered(1);- }-}--void HsQMLObjectProxy::deref(RefSrc src)-{- // Remove JavaScript GC lock when there are no handles- if (src == Handle) {- int hndlCount = mHndlCount.fetchAndAddOrdered(-1);- if (hndlCount == 1 && mObject) {- // This will increment the reference count for the lifetime of the- // of the event.- gManager->postObjectEvent(new HsQMLObjectEvent(this));- }- }-- int count = mRefCount.fetchAndAddOrdered(-1);-- HSQML_LOG(count == 1 ? 3 : 4,- QString().sprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",- count > 1 ? "Deref" : "Delete", mKlass->name(),- mSerial, cRefSrcNames[src], count));-- if (count == 1) {- delete this;- }-}--HsQMLObjectEvent::HsQMLObjectEvent(HsQMLObjectProxy* proxy)- : QEvent(HsQMLManagerApp::RemoveGCLockEvent)- , mProxy(proxy)-{- mProxy->ref(HsQMLObjectProxy::Event);-}--HsQMLObjectEvent::~HsQMLObjectEvent()-{- mProxy->deref(HsQMLObjectProxy::Event);-}--void HsQMLObjectEvent::process()-{- Q_ASSERT(type() == HsQMLManagerApp::RemoveGCLockEvent);- mProxy->removeGCLock();-}--HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy, HsQMLEngine* engine)- : mProxy(proxy)- , mHaskell(proxy->haskell())- , mKlass(proxy->klass())- , mEngine(engine)-{- QDeclarativeEngine::setObjectOwnership(- this, QDeclarativeEngine::JavaScriptOwnership);- mProxy->ref(HsQMLObjectProxy::Object);- gManager->updateCounter(HsQMLManager::QObjectCount, 1);-}--HsQMLObject::~HsQMLObject()-{- mProxy->clearObject();- mProxy->deref(HsQMLObjectProxy::Object);- gManager->updateCounter(HsQMLManager::QObjectCount, -1);-}--const QMetaObject* HsQMLObject::metaObject() const-{- return QObject::d_ptr->metaObject ?- QObject::d_ptr->metaObject : mKlass->metaObj();-}--void* HsQMLObject::qt_metacast(const char* clname)-{- if (!clname) {- return 0;- }- if (!strcmp(clname, mKlass->metaObj()->className())) {- return static_cast<void*>(const_cast<HsQMLObject*>(this));- }- return QObject::qt_metacast(clname);-}--int HsQMLObject::qt_metacall(QMetaObject::Call c, int id, void** a)-{- id = QObject::qt_metacall(c, id, a);- if (id < 0) {- return id;- }- gManager->setActiveEngine(mEngine);- if (QMetaObject::InvokeMetaMethod == c) {- mKlass->methods()[id](this, a);- id -= mKlass->methodCount();- }- else if (QMetaObject::ReadProperty == c) {- mKlass->properties()[2*id](this, a);- id -= mKlass->propertyCount();- }- else if (QMetaObject::WriteProperty == c) {- HsQMLUniformFunc uf = mKlass->properties()[2*id+1];- if (uf) {- uf(this, a);- }- id -= mKlass->propertyCount();- }- else if (QMetaObject::QueryPropertyDesignable == c ||- QMetaObject::QueryPropertyScriptable == c ||- QMetaObject::QueryPropertyStored == c ||- QMetaObject::QueryPropertyEditable == c ||- QMetaObject::QueryPropertyUser == c) {- id -= mKlass->propertyCount();- }- gManager->setActiveEngine(NULL);- return id;-}--void HsQMLObject::setGCLock()-{- mGCLock = mEngine->scriptEngine()->newQObject(- this, QScriptEngine::ScriptOwnership);-}--void HsQMLObject::clearGCLock()-{- mGCLock = QScriptValue();-}--bool HsQMLObject::isGCLocked() const-{- return mGCLock.isValid();-}--HsQMLObjectProxy* HsQMLObject::proxy() const-{- return mProxy;-}--HsQMLEngine* HsQMLObject::engine() const-{- return mEngine;-}--extern "C" HsQMLObjectHandle* hsqml_create_object(- HsStablePtr haskell, HsQMLClassHandle* kHndl)-{- HsQMLObjectProxy* proxy = new HsQMLObjectProxy(haskell, (HsQMLClass*)kHndl);- return (HsQMLObjectHandle*)proxy;-}--extern "C" void hsqml_object_set_active(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- if (proxy) {- gManager->setActiveEngine(proxy->engine());- }- else {- gManager->setActiveEngine(NULL);- }-}--extern "C" HsStablePtr hsqml_object_get_hs_typerep(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return proxy->klass()->hsTypeRep();-}--extern HsStablePtr hsqml_object_get_haskell(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return proxy->haskell();-}--extern void* hsqml_object_get_pointer(- HsQMLObjectHandle* hndl)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- return (void*)proxy->object(gManager->activeEngine());-}--extern HsQMLObjectHandle* hsqml_get_object_handle(- void* ptr)-{- // Return NULL if the input pointer is NULL- if (!ptr) {- return NULL;- }-- // Get object proxy- HsQMLObject* object = (HsQMLObject*)ptr;- HsQMLObjectProxy* proxy = object->proxy();- proxy->ref(HsQMLObjectProxy::Handle);- proxy->tryGCLock();-- return (HsQMLObjectHandle*)proxy;-}--extern void hsqml_finalise_object_handle(- HsQMLObjectHandle* hndl)-{- if (hndl) {- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- proxy->deref(HsQMLObjectProxy::Handle);- }-}--extern void hsqml_fire_signal(- HsQMLObjectHandle* hndl, int idx, void** args)-{- HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;- HsQMLEngine* engine = proxy->engine();- // Ignore objects which haven't been marshalled as they are not connected.- if (engine) {- // Clear active engine in case the slot code calls back into Haskell.- Q_ASSERT(gManager->activeEngine() == engine);- gManager->setActiveEngine(NULL);- HsQMLObject* obj = proxy->object(engine);- QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args);- }-}
− cbits/HsQMLObject.h
@@ -1,71 +0,0 @@-#ifndef HSQML_OBJECT_H-#define HSQML_OBJECT_H--#include <QtCore/QObject>-#include <QtCore/QAtomicInt>-#include <QtCore/QEvent>-#include <QtScript/QScriptValue>--class HsQMLEngine;-class HsQMLClass;-class HsQMLObject;--class HsQMLObjectProxy-{-public:- HsQMLObjectProxy(HsStablePtr, HsQMLClass*);- virtual ~HsQMLObjectProxy();- HsStablePtr haskell() const;- HsQMLClass* klass() const;- HsQMLObject* object(HsQMLEngine*);- void clearObject();- void tryGCLock();- void removeGCLock();- HsQMLEngine* engine() const;- enum RefSrc {Handle, Object, Event};- void ref(RefSrc);- void deref(RefSrc);--private:- HsStablePtr mHaskell;- HsQMLClass* mKlass;- int mSerial;- HsQMLObject* volatile mObject;- QAtomicInt mRefCount;- QAtomicInt mHndlCount;-};--class HsQMLObjectEvent : public QEvent-{-public:- HsQMLObjectEvent(HsQMLObjectProxy*);- virtual ~HsQMLObjectEvent();- void process();--private:- HsQMLObjectProxy* mProxy;-};--class HsQMLObject : public QObject-{-public:- HsQMLObject(HsQMLObjectProxy*, HsQMLEngine*);- virtual ~HsQMLObject();- virtual const QMetaObject* metaObject() const;- virtual void* qt_metacast(const char*);- virtual int qt_metacall(QMetaObject::Call, int, void**);- void setGCLock();- void clearGCLock();- bool isGCLocked() const;- HsQMLObjectProxy* proxy() const;- HsQMLEngine* engine() const;--private:- HsQMLObjectProxy* mProxy;- HsStablePtr mHaskell;- HsQMLClass* mKlass;- HsQMLEngine* mEngine;- QScriptValue mGCLock;-};--#endif /*HSQML_OBJECT_H*/
− cbits/HsQMLWindow.cpp
@@ -1,107 +0,0 @@-#include "hsqml.h"-#include "HsQMLManager.h"-#include "HsQMLWindow.h"--HsQMLWindow::HsQMLWindow(HsQMLEngine* engine)- : QObject(engine)- , mEngine(engine)- , mContext(engine->declEngine())- , mView(&mScene)- , mComponent(NULL)-{- // Setup context- mContext.setContextProperty("window", this);-- // Handle Window close event manually- mWindow.setAttribute(Qt::WA_DeleteOnClose, false);- mWindow.installEventFilter(this);-- // Setup for QML performance- mView.setOptimizationFlags(QGraphicsView::DontSavePainterState);- mView.setViewportUpdateMode(QGraphicsView::BoundingRectViewportUpdate);- mScene.setItemIndexMethod(QGraphicsScene::NoIndex);-- // Setup for QML key handling- mView.viewport()->setFocusPolicy(Qt::NoFocus);- mView.setFocusPolicy(Qt::StrongFocus);- mScene.setStickyFocus(true);-- mWindow.setCentralWidget(&mView);-}--HsQMLWindow::~HsQMLWindow()-{-}--bool HsQMLWindow::eventFilter(QObject* obj, QEvent* ev)-{- if (obj == &mWindow && ev->type() == QEvent::Close) {- deleteLater();- }- return false;-}--QUrl HsQMLWindow::source() const-{- return mSource;-}--void HsQMLWindow::setSource(const QUrl& url)-{- mSource = url;- if (mComponent) {- delete mComponent;- mComponent = NULL;- }- if (!mSource.isEmpty()) {- mComponent = new QDeclarativeComponent(- mEngine->declEngine(), mSource, this);- if (mComponent->isLoading()) {- QObject::connect(- mComponent,- SIGNAL(statusChanged(QDeclarativeComponent::Status)),- this,- SLOT(completeSetSource()));- }- else {- completeSetSource();- }- }-}--void HsQMLWindow::completeSetSource()-{- QObject::disconnect(- mComponent, SIGNAL(statusChanged(QDeclarativeComponent::Status)),- this, SLOT(completeSetSource()));- QDeclarativeItem* item =- qobject_cast<QDeclarativeItem*>(mComponent->create(&mContext));- if (item) {- mScene.addItem(item);- }-}--QString HsQMLWindow::title() const-{- return mWindow.windowTitle();-}--void HsQMLWindow::setTitle(const QString& title)-{- mWindow.setWindowTitle(title);-}--bool HsQMLWindow::visible() const-{- return mWindow.isVisible();-}--void HsQMLWindow::setVisible(bool visible)-{- mWindow.setVisible(visible);-}--void HsQMLWindow::close()-{- deleteLater();-}
− cbits/HsQMLWindow.h
@@ -1,45 +0,0 @@-#ifndef HSQML_WINDOW_H-#define HSQML_WINDOW_H--#include <QtCore/QUrl>-#include <QtGui/QMainWindow>-#include <QtGui/QGraphicsScene>-#include <QtGui/QGraphicsView>-#include <QtDeclarative/QDeclarativeContext>-#include <QtDeclarative/QDeclarativeItem>--#include "HsQMLManager.h"--class QDeclarativeComponent;--class HsQMLWindow : public QObject-{- Q_OBJECT--public:- HsQMLWindow(HsQMLEngine*);- virtual ~HsQMLWindow();- virtual bool eventFilter(QObject*, QEvent*);- QUrl source() const;- void setSource(const QUrl&);- Q_PROPERTY(QUrl source READ source WRITE setSource);- QString title() const;- void setTitle(const QString&);- Q_PROPERTY(QString title READ title WRITE setTitle);- bool visible() const;- void setVisible(bool);- Q_PROPERTY(bool visible READ visible WRITE setVisible);- Q_SCRIPTABLE void close();--private:- Q_SLOT void completeSetSource();- HsQMLEngine* mEngine;- QDeclarativeContext mContext;- QMainWindow mWindow;- QGraphicsScene mScene;- QGraphicsView mView;- QUrl mSource;- QDeclarativeComponent* mComponent;-};--#endif /*HSQML_WINDOW_H*/
+ cbits/Intrinsics.cpp view
@@ -0,0 +1,171 @@+#include <QtCore/QString>+#include <QtCore/QMetaType>+#include <QtQml/QJSValue>++#include "Manager.h"+#include "Engine.h"++/* String */+extern "C" size_t hsqml_get_string_size()+{+ return sizeof(QString);+}++extern "C" void hsqml_init_string(HsQMLStringHandle* hndl)+{+ new((void*)hndl) QString();+}++extern "C" void hsqml_deinit_string(HsQMLStringHandle* hndl)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ string->~QString();+}++extern "C" UTF16* hsqml_write_string(+ int bufLen, HsQMLStringHandle* hndl)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ string->resize(bufLen);+ return reinterpret_cast<UTF16*>(string->data());+}++extern "C" int hsqml_read_string(+ HsQMLStringHandle* hndl, UTF16** bufPtr)+{+ QString* string = reinterpret_cast<QString*>(hndl);+ *bufPtr = reinterpret_cast<UTF16*>(string->data());+ return string->length();+}++/* JSValue */+extern "C" size_t hsqml_get_jval_size()+{+ return sizeof(QJSValue);+}++extern "C" int hsqml_get_jval_typeid()+{+ return qMetaTypeId<QJSValue>();+}++extern "C" void hsqml_init_jval_null(HsQMLJValHandle* hndl, int undef)+{+ new((void*)hndl) QJSValue(undef ?+ QJSValue::UndefinedValue : QJSValue::NullValue);+}++extern "C" void hsqml_set_jval(HsQMLJValHandle* hndl, HsQMLJValHandle* srch)+{+ QJSValue* dstValue = reinterpret_cast<QJSValue*>(hndl);+ QJSValue* srcValue = reinterpret_cast<QJSValue*>(srch);+ *dstValue = *srcValue;+}++extern "C" void hsqml_deinit_jval(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ value->~QJSValue();+}+++extern "C" void hsqml_init_jval_bool(HsQMLJValHandle* hndl, int b)+{+ new((void*)hndl) QJSValue((bool)b);+}++extern "C" int hsqml_is_jval_bool(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isBool();+}++extern "C" int hsqml_get_jval_bool(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toBool();+}++extern "C" void hsqml_init_jval_int(HsQMLJValHandle* hndl, int i)+{+ new((void*)hndl) QJSValue((int)i);+}++extern "C" void hsqml_init_jval_double(HsQMLJValHandle* hndl, double f)+{+ new((void*)hndl) QJSValue((double)f);+}++extern "C" int hsqml_is_jval_number(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isNumber();+}++extern "C" int hsqml_get_jval_int(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toInt();+}++extern "C" double hsqml_get_jval_double(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->toNumber();+}++extern "C" void hsqml_init_jval_string(+ HsQMLJValHandle* hndl, HsQMLStringHandle* strh)+{+ QString* string = reinterpret_cast<QString*>(strh);+ new((void*)hndl) QJSValue(*string);+}+extern "C" int hsqml_is_jval_string(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isString();+}++extern "C" void hsqml_get_jval_string(+ HsQMLJValHandle* hndl, HsQMLStringHandle* strh)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ QString* string = reinterpret_cast<QString*>(strh);+ *string = value->toString();+}++/* Array */+extern "C" void hsqml_init_jval_array(HsQMLJValHandle* hndl, unsigned int len)+{+ HsQMLEngine* engine = gManager->activeEngine();+ Q_ASSERT(engine);+ new((void*)hndl) QJSValue(engine->declEngine()->newArray(len));+}++extern "C" int hsqml_is_jval_array(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->isArray();+}++extern "C" unsigned int hsqml_get_jval_array_length(HsQMLJValHandle* hndl)+{+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ return value->property("length").toUInt();+}++extern "C" void hsqml_jval_array_get(+ HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl)+{+ QJSValue* array = reinterpret_cast<QJSValue*>(ahndl);+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ *value = array->property(i);+}++extern "C" void hsqml_jval_array_set(+ HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl)+{+ QJSValue* array = reinterpret_cast<QJSValue*>(ahndl);+ QJSValue* value = reinterpret_cast<QJSValue*>(hndl);+ array->setProperty(i, *value);+}
+ cbits/Manager.cpp view
@@ -0,0 +1,632 @@+#include <cstdio>+#include <cstdlib>+#include <QtCore/QBasicTimer>+#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+Q_DECL_IMPORT const QVariant::Handler* qcoreVariantHandler();+namespace QVariantPrivate {+Q_DECL_IMPORT void registerHandler(+ const int name, const QVariant::Handler *handler);+}++static const char* cCounterNames[] = {+ "ClassCounter",+ "ObjectCounter",+ "QObjectCounter",+ "EngineCounter",+ "VariantCounter",+ "ClassSerial",+ "ObjectSerial",+ "EngineSerial",+};++// This definition overrides a symbol in the GHC RTS+#ifdef HSQML_USE_EXIT_HOOK+#ifdef Q_OS_LINUX // TODO: Test on other platforms.+extern "C" void OnExitHook()+{+ if (gManager) {+ gManager->shutdown();+ }+}+#endif+#endif++static void dump_counters()+{+ Q_ASSERT (gManager);+ if (gManager->checkLogLevel(1)) {+ for (int i=0; i<HsQMLManager::TotalCounters; i++) {+ gManager->log(QString().sprintf("%s = %d.",+ cCounterNames[i], gManager->updateCounter(+ static_cast<HsQMLManager::CounterId>(i), 0)));+ }+ }+}++static void hooked_construct(QVariant::Private* p, const void* copy)+{+ gManager->hookedConstruct(p, copy);+}++static void hooked_clear(QVariant::Private* p)+{+ gManager->hookedClear(p);+}++ManagerPointer gManager;++HsQMLManager::HsQMLManager(+ void (*freeFun)(HsFunPtr),+ void (*freeStable)(HsStablePtr))+ : mLogLevel(0)+ , mAtExit(false)+ , mFreeFun(freeFun)+ , mFreeStable(freeStable)+ , mOriginalHandler(qcoreVariantHandler())+ , mApp(NULL)+ , mLock(QMutex::Recursive)+ , mRunning(false)+ , mRunCount(0)+ , mShutdown(false)+ , mStackBase(NULL)+ , mStartCb(NULL)+ , 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) {+ setLogLevel(QString(env).toInt());+ }+}++void HsQMLManager::setLogLevel(int ll)+{+ mLogLevel = ll;+ if (ll > 0 && !mAtExit) {+ if (atexit(&dump_counters) == 0) {+ mAtExit = true;+ }+ else {+ log("Failed to register callback with atexit().");+ }+ }+}++bool HsQMLManager::checkLogLevel(int ll)+{+ return mLogLevel >= ll;+}++void HsQMLManager::log(const QString& msg)+{+ QMutexLocker locker(&mLogLock);+ fprintf(stderr, "HsQML: %s\n", msg.toUtf8().data());+}++int HsQMLManager::updateCounter(CounterId id, int delta)+{+ return mCounters[id].fetchAndAddRelaxed(delta);+}++void HsQMLManager::freeFun(HsFunPtr funPtr)+{+ mFreeFun(funPtr);+}++void HsQMLManager::freeStable(HsStablePtr stablePtr)+{+ 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);+}++void HsQMLManager::unregisterObject(const QObject* obj)+{+ bool removed = mObjectSet.remove(obj);+ Q_ASSERT(removed);+}++void HsQMLManager::hookedConstruct(QVariant::Private* p, const void* copy)+{+ char guard;+ mOriginalHandler->construct(p, copy);+ void* pp = reinterpret_cast<void*>(p);+ // The QVariant internals sometimes use a special code path for pointer+ // values which avoids calling the handler functions. This makes it+ // difficult to use them to keep a reference count. However, it's my+ // observation that this only affects transient QVariants created on the+ // stack inside the JavaScript engine's marshalling code. The persistent+ // QVariants stored in the heap are manipulated using a more restricted set+ // of operations which always use the handler functions. Hence, by assuming+ // that the stack can be discounted, it's possible to keep an accurate+ // count of heap references using these hooks.+ if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) {+ if (isEventThread() && mObjectSet.contains(p->data.o)) {+ HsQMLObject* obj = static_cast<HsQMLObject*>(p->data.o);+ HsQMLObjectProxy* proxy = obj->proxy();+ proxy->ref(HsQMLObjectProxy::Variant);+ proxy->tryGCLock();+ updateCounter(VariantCount, 1);+ }+ }+}++void HsQMLManager::hookedClear(QVariant::Private* p)+{+ char guard;+ void* pp = reinterpret_cast<void*>(p);+ if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) {+ if (isEventThread() && mObjectSet.contains(p->data.o)) {+ HsQMLObject* obj = static_cast<HsQMLObject*>(p->data.o);+ obj->proxy()->deref(HsQMLObjectProxy::Variant);+ updateCounter(VariantCount, -1);+ }+ }+ mOriginalHandler->clear(p);+}++bool HsQMLManager::isEventThread()+{+ return mApp && mApp->thread() == QThread::currentThread();+}++HsQMLManager::EventLoopStatus HsQMLManager::runEventLoop(+ HsQMLTrivialCb startCb,+ HsQMLTrivialCb jobsCb,+ HsQMLTrivialCb yieldCb)+{+ QMutexLocker locker(&mLock);++ // Check for invalid state+ if (mRunning) {+ return HSQML_EVLOOP_ALREADY_RUNNING;+ }+ else if (mShutdown) {+ return HSQML_EVLOOP_POST_SHUTDOWN;+ }++ // Check if event loop bound to a different thread+ if (mApp && !isEventThread()) {+ return HSQML_EVLOOP_WRONG_THREAD;+ }++#ifdef Q_OS_MAC+ if (!pthread_main_np()) {+ // Cocoa can only be run on the primordial thread and exec() doesn't+ // check this.+ return HSQML_EVLOOP_WRONG_THREAD;+ }+#endif++ // Check for non-threaded RTS+ if (yieldCb) {+ HSQML_LOG(0,+ "Warning: CPU cannot idle when using the non-threaded RTS.");+ }++ // Create application object+ if (!mApp) {+ mApp = new HsQMLManagerApp();+ }++ // Save stack base and callbacks+ mStackBase = &locker;+ mStartCb = startCb;+ mJobsCb = jobsCb;+ mYieldCb = yieldCb;++ // Setup events+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StartedLoopEvent),+ Qt::HighEventPriority);+ QBasicTimer idleTimer;+ if (yieldCb) {+ idleTimer.start(0, mApp);+ }++ // Run loop+ int ret;+ do {+ ret = mApp->exec();++ // Kill all engines+ const QObjectList& cs = gManager->mApp->children();+ while (!cs.empty()) {+ delete cs.front();+ }++ // Cmd-Q on MacOS can kill the event loop before we're ready+ // Keep it running until a StopLoopEvent is received+ } while (ret == 0 && mRunning);++ // Remove redundant events+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::RemoveGCLockEvent);++ // Cleanup callbacks+ freeFun(startCb);+ mStartCb = NULL;+ freeFun(jobsCb);+ mJobsCb = NULL;+ if (yieldCb) {+ freeFun(yieldCb);+ mYieldCb = NULL;+ }++ // Return+ if (ret == 0) {+ return HSQML_EVLOOP_OK;+ }+ else {+ QCoreApplication::removePostedEvents(+ mApp, HsQMLManagerApp::StartedLoopEvent);+ return HSQML_EVLOOP_OTHER_ERROR;+ }+}++HsQMLManager::EventLoopStatus HsQMLManager::requireEventLoop()+{+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ mRunCount++;+ return HSQML_EVLOOP_OK;+ }+ else {+ return HSQML_EVLOOP_NOT_RUNNING;+ }+}++void HsQMLManager::releaseEventLoop()+{+ QMutexLocker locker(&mLock);+ if (--mRunCount == 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::StopLoopEvent),+ Qt::LowEventPriority);+ }+}++void HsQMLManager::notifyJobs()+{+ QMutexLocker locker(&mLock);+ if (mRunCount > 0) {+ QCoreApplication::postEvent(+ mApp, new QEvent(HsQMLManagerApp::PendingJobsEvent));+ }+}++void HsQMLManager::setActiveEngine(HsQMLEngine* engine)+{+ Q_ASSERT(!mActiveEngine || !engine);+ mActiveEngine = engine;+}++HsQMLEngine* HsQMLManager::activeEngine()+{+ return mActiveEngine;+}++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);++ if (mRunning) {+ return HSQML_EVLOOP_ALREADY_RUNNING;+ }+ else if (isEventThread()) {+ HSQML_LOG(1, "Deleting QApplication object.");+ delete mApp;+ mApp = NULL;+ mShutdown = true;+ }+ else if (mApp) {+ return HSQML_EVLOOP_WRONG_THREAD; + }+ return HSQML_EVLOOP_OK;+}++HsQMLManagerApp::HsQMLManagerApp()+ : 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+ mHookedHandler.construct = &hooked_construct;+ mHookedHandler.clear = &hooked_clear;+ QVariantPrivate::registerHandler(0, &mHookedHandler);++ // Register custom types+ 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)+{+ switch (ev->type()) {+ case HsQMLManagerApp::StartedLoopEvent: {+ gManager->mRunning = true;+ gManager->mRunCount++;+ gManager->mLock.unlock();+ gManager->mStartCb();+ gManager->mJobsCb();+ break;}+ case HsQMLManagerApp::StopLoopEvent: {+ gManager->mLock.lock();+ gManager->mRunning = false;+ gManager->mApp->mApp.quit();+ break;}+ case HsQMLManagerApp::PendingJobsEvent: {+ gManager->mJobsCb();+ break;}+ 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;+ }+}++void HsQMLManagerApp::timerEvent(QTimerEvent*)+{+ Q_ASSERT(gManager->mYieldCb);+ gManager->mYieldCb();+}++int HsQMLManagerApp::exec()+{+ return mApp.exec();+}++void HsQMLManagerApp::setWindowIcon(QIcon* icon)+{+ if (icon != nullptr) {+ mApp.setWindowIcon(*icon);+ delete icon;+ }+}++void HsQMLManager::setWindowIcon(const QString& iconPath)+{+ if (mApp != nullptr) {+ mApp->setWindowIcon(new QIcon(iconPath));+ }+}++extern "C" void hsqml_init(+ void (*freeFun)(HsFunPtr),+ void (*freeStable)(HsStablePtr))+{+ if (gManager == NULL) {+ HsQMLManager* manager = new HsQMLManager(freeFun, freeStable);+ if (!gManager.testAndSetOrdered(NULL, manager)) {+ delete manager;+ }+ }+}++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,+ HsQMLTrivialCb yieldCb)+{+ return gManager->runEventLoop(startCb, jobsCb, yieldCb);+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_require()+{+ return gManager->requireEventLoop();+}++extern "C" void hsqml_evloop_release()+{+ gManager->releaseEventLoop();+}++extern "C" void hsqml_evloop_notify_jobs()+{+ gManager->notifyJobs();+}++extern "C" HsQMLEventLoopStatus hsqml_evloop_shutdown()+{+ if (gManager) {+ return gManager->shutdown();+ }+ return HSQML_EVLOOP_OK;+}++extern "C" void hsqml_set_debug_loglevel(int ll)+{+ 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
@@ -0,0 +1,153 @@+#ifndef HSQML_MANAGER_H+#define HSQML_MANAGER_H++#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"++#define HSQML_LOG(ll, msg) if (gManager->checkLogLevel(ll)) gManager->log(msg)++class HsQMLManagerApp;+class HsQMLClass;+class HsQMLEngine;++class HsQMLManager+{+public:+ enum CounterId {+ ClassCount,+ ObjectCount,+ QObjectCount,+ VariantCount,+ EngineCount,+ ClassSerial,+ ObjectSerial,+ EngineSerial,+ TotalCounters+ }; ++ HsQMLManager(+ void (*)(HsFunPtr),+ void (*)(HsStablePtr));+ void setLogLevel(int);+ bool checkLogLevel(int);+ void log(const QString&);+ 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*);+ void hookedClear(QVariant::Private*);+ bool isEventThread();+ typedef HsQMLEventLoopStatus EventLoopStatus;+ EventLoopStatus runEventLoop(+ HsQMLTrivialCb, HsQMLTrivialCb, HsQMLTrivialCb);+ EventLoopStatus requireEventLoop();+ void releaseEventLoop();+ void notifyJobs();+ void setActiveEngine(HsQMLEngine*);+ HsQMLEngine* activeEngine();+ void postAppEvent(QEvent*);+ void zombifyClass(HsQMLClass*);+ EventLoopStatus shutdown();+ void setWindowIcon(const QString& iconPath);++private:+ friend class HsQMLManagerApp;+ Q_DISABLE_COPY(HsQMLManager)++ int mLogLevel;+ QMutex mLogLock;+ QAtomicInt mCounters[TotalCounters];+ 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;+ bool mRunning;+ int mRunCount;+ bool mShutdown;+ void* mStackBase;+ HsQMLTrivialCb mStartCb;+ HsQMLTrivialCb mJobsCb;+ HsQMLTrivialCb mYieldCb;+ HsQMLEngine* mActiveEngine;+ bool mQmlDebugEnabled;+};++class HsQMLManagerApp : public QObject+{+ Q_OBJECT++public:+ HsQMLManagerApp();+ virtual ~HsQMLManagerApp();+ virtual void customEvent(QEvent*);+ virtual void timerEvent(QTimerEvent*);+ virtual void setWindowIcon(QIcon*);+ int exec();++ enum CustomEventIndicies {+ StartedLoopEventIndex,+ StopLoopEventIndex,+ PendingJobsEventIndex,+ RemoveGCLockEventIndex,+ CreateEngineEventIndex,+ };++ static const QEvent::Type StartedLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StartedLoopEventIndex);+ static const QEvent::Type StopLoopEvent =+ static_cast<QEvent::Type>(QEvent::User+StopLoopEventIndex);+ static const QEvent::Type PendingJobsEvent =+ 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)++ QVariant::Handler mHookedHandler;+ int mArgC;+ QApplication mApp;+};++class ManagerPointer : public QAtomicPointer<HsQMLManager>+{+public:+ HsQMLManager* operator->() const+ {+ return load();+ }++ operator HsQMLManager*() const+ {+ return load();+ }+};++extern ManagerPointer gManager;++#endif /*HSQML_MANAGER_H*/
+ 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
@@ -0,0 +1,463 @@+#include <HsFFI.h>+#include <QtCore/QString>+#include <QtCore/QMutexLocker>+#include <QtQml/QQmlEngine>++#include "Object.h"+#include "Class.h"+#include "Engine.h"+#include "Manager.h"++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)+{}++HsQMLObjectFinaliser::~HsQMLObjectFinaliser()+{+ gManager->freeFun(reinterpret_cast<HsFunPtr>(mFinaliseCb));+}++void HsQMLObjectFinaliser::finalise(HsQMLObjectProxy* proxy) const+{+ mFinaliseCb(reinterpret_cast<HsQMLObjectHandle*>(proxy));+}++HsQMLObjectProxy::HsQMLObjectProxy(HsStablePtr haskell, HsQMLClass* klass)+ : mHaskell(haskell)+ , mKlass(klass)+ , mSerial(gManager->updateCounter(HsQMLManager::ObjectSerial, 1))+ , mObject(NULL)+ , mRefCount(0)+{+ ref(Handle);+ mKlass->ref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, 1);+}++HsQMLObjectProxy::~HsQMLObjectProxy()+{+ mKlass->deref(HsQMLClass::ObjProxy);+ gManager->updateCounter(HsQMLManager::ObjectCount, -1);+ gManager->freeStable(mHaskell);+}++HsStablePtr HsQMLObjectProxy::haskell() const+{+ return mHaskell;+}++HsQMLClass* HsQMLObjectProxy::klass() const+{+ return mKlass;+}++HsQMLObject* HsQMLObjectProxy::object(HsQMLEngine* engine)+{+ Q_ASSERT(gManager->isEventThread());+ Q_ASSERT(engine);+ if (!mObject) {+ mObject = new HsQMLObject(this, engine);++ HSQML_LOG(5,+ QString().asprintf("New QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }++ // Old objects may have lost their lock via weak references in addition+ // to new objects needing it.+ tryGCLock();++ return mObject;+}++void HsQMLObjectProxy::clearObject()+{+ Q_ASSERT(gManager->isEventThread());++ HSQML_LOG(5,+ QString().asprintf("Release QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));++ mObject = NULL;+ runFinalisers();+}++void HsQMLObjectProxy::tryGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mStrongCount.loadAcquire() > 0 && !mObject->isGCLocked()) {+ mObject->setGCLock();++ HSQML_LOG(5,+ QString().asprintf("Lock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+}++void HsQMLObjectProxy::removeGCLock()+{+ Q_ASSERT(gManager->isEventThread());++ if (mObject && mStrongCount.loadAcquire() == 0) {+ if (mObject->isGCLocked()) {+ mObject->clearGCLock();++ HSQML_LOG(5,+ QString().asprintf("Unlock QObject, class=%s, id=%d, qptr=%p.",+ mKlass->name(), mSerial, mObject));+ }+ else {+ // If there had been a QML object then this would have happened+ // when the QML GC collected it.+ runFinalisers();+ }+ }+}++void HsQMLObjectProxy::addFinaliser(const HsQMLObjectFinaliser::Ref& f)+{+ QMutexLocker locker(&mFinaliseMutex);+ mFinalisers.append(f);+}++void HsQMLObjectProxy::runFinalisers()+{+ // Copy and clear finalisers under lock+ mFinaliseMutex.lock();+ const Finalisers fs = mFinalisers;+ mFinalisers.clear();+ mFinaliseMutex.unlock();++ // Call finalisers outside lock so they can re-addFinaliser()+ Q_FOREACH(const HsQMLObjectFinaliser::Ref& f, fs) {+ ref(Handle);+ f->finalise(this);+ }+}++HsQMLEngine* HsQMLObjectProxy::engine() const+{+ if (mObject != NULL) {+ return mObject->engine();+ }+ return NULL;+}++void HsQMLObjectProxy::ref(RefSrc src)+{+ int count = mRefCount.fetchAndAddOrdered(1);++ HSQML_LOG(count == 0 ? 3 : 4,+ QString().asprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count ? "Ref" : "New", mKlass->name(),+ mSerial, cRefSrcNames[src], count+1));++ if (isStrongRef(src)) {+ mStrongCount.fetchAndAddOrdered(1);+ }+}++void HsQMLObjectProxy::deref(RefSrc src)+{+ // Remove JavaScript GC lock when there are no strong handles+ 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->postAppEvent(new HsQMLObjectEvent(this));+ }+ else {+ removeGCLock();+ }+ }+ }++ int count = mRefCount.fetchAndAddOrdered(-1);++ HSQML_LOG(count == 1 ? 3 : 4,+ QString().asprintf("%s ObjProxy, class=%s, id=%d, src=%s, count=%d.",+ count > 1 ? "Deref" : "Delete", mKlass->name(),+ mSerial, cRefSrcNames[src], count));++ if (count == 1) {+ delete this;+ }+}++HsQMLObjectEvent::HsQMLObjectEvent(HsQMLObjectProxy* proxy)+ : QEvent(HsQMLManagerApp::RemoveGCLockEvent)+ , mProxy(proxy)+{+ mProxy->ref(HsQMLObjectProxy::Event);+}++HsQMLObjectEvent::~HsQMLObjectEvent()+{+ mProxy->deref(HsQMLObjectProxy::Event);+}++void HsQMLObjectEvent::process()+{+ Q_ASSERT(type() == HsQMLManagerApp::RemoveGCLockEvent);+ mProxy->removeGCLock();+}++HsQMLObject::HsQMLObject(HsQMLObjectProxy* proxy, HsQMLEngine* engine)+ : mProxy(proxy)+ , mHaskell(proxy->haskell())+ , mKlass(proxy->klass())+ , mEngine(engine)+{+ QQmlEngine::setObjectOwnership(+ this, QQmlEngine::JavaScriptOwnership);+ mProxy->ref(HsQMLObjectProxy::Object);+ gManager->registerObject(this);+ gManager->updateCounter(HsQMLManager::QObjectCount, 1);+}++HsQMLObject::~HsQMLObject()+{+ mProxy->clearObject();+ mProxy->deref(HsQMLObjectProxy::Object);+ gManager->unregisterObject(this);+ gManager->updateCounter(HsQMLManager::QObjectCount, -1);+}++const QMetaObject* HsQMLObject::metaObject() const+{+ return QObject::d_ptr->metaObject ?+ QObject::d_ptr->dynamicMetaObject() : mKlass->metaObj();+}++void* HsQMLObject::qt_metacast(const char* clname)+{+ if (!clname) {+ return 0;+ }+ if (!strcmp(clname, mKlass->metaObj()->className())) {+ return static_cast<void*>(const_cast<HsQMLObject*>(this));+ }+ return QObject::qt_metacast(clname);+}++int HsQMLObject::qt_metacall(QMetaObject::Call c, int id, void** a)+{+ id = QObject::qt_metacall(c, id, a);+ if (id < 0) {+ return id;+ }+ gManager->setActiveEngine(mEngine);+ if (QMetaObject::InvokeMetaMethod == c) {+ mKlass->methods()[id](this, a);+ id -= mKlass->methodCount();+ }+ else if (QMetaObject::ReadProperty == c) {+ mKlass->properties()[2*id](this, a);+ id -= mKlass->propertyCount();+ }+ else if (QMetaObject::WriteProperty == c) {+ HsQMLUniformFunc uf = mKlass->properties()[2*id+1];+ if (uf) {+ uf(this, a);+ }+ id -= mKlass->propertyCount();+ }+ else if (QMetaObject::QueryPropertyDesignable == c ||+ QMetaObject::QueryPropertyScriptable == c ||+ QMetaObject::QueryPropertyStored == c ||+ QMetaObject::QueryPropertyEditable == c ||+ QMetaObject::QueryPropertyUser == c) {+ id -= mKlass->propertyCount();+ }+ gManager->setActiveEngine(NULL);+ return id;+}++void HsQMLObject::setGCLock()+{+ mGCLock = mEngine->declEngine()->newQObject(this);+}++void HsQMLObject::clearGCLock()+{+ mGCLock = QJSValue(QJSValue::NullValue);+}++bool HsQMLObject::isGCLocked() const+{+ return mGCLock.isQObject();+}++QJSValue* HsQMLObject::gcLockVar()+{+ return &mGCLock;+}++HsQMLObjectProxy* HsQMLObject::proxy() const+{+ return mProxy;+}++HsQMLEngine* HsQMLObject::engine() const+{+ return mEngine;+}++extern "C" HsQMLObjectHandle* hsqml_create_object(+ HsStablePtr haskell, HsQMLClassHandle* kHndl)+{+ HsQMLObjectProxy* proxy = new HsQMLObjectProxy(haskell, (HsQMLClass*)kHndl);+ return (HsQMLObjectHandle*)proxy;+}++extern "C" int hsqml_object_set_active(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ if (proxy) {+ HsQMLEngine* engine = proxy->engine();+ if (engine) {+ gManager->setActiveEngine(engine);+ }+ else {+ // Nothing can be done if the object hasn't been marshalled before+ // because otherwise the relevant engine is unknown.+ return false;+ }+ }+ else {+ gManager->setActiveEngine(NULL);+ }+ return true;+}++extern "C" HsStablePtr hsqml_object_get_hs_typerep(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ return proxy->klass()->hsTypeRep();+}++extern HsStablePtr hsqml_object_get_hs_value(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ return proxy->haskell();+}++extern void* hsqml_object_get_pointer(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+ return (void*)proxy->object(gManager->activeEngine());+}++extern HsQMLJValHandle* hsqml_object_get_jval(+ HsQMLObjectHandle* hndl)+{+ HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+ HsQMLObject* obj = proxy->object(gManager->activeEngine());+ return reinterpret_cast<HsQMLJValHandle*>(obj->gcLockVar());+}++extern HsQMLObjectHandle* hsqml_get_object_from_pointer(+ void* ptr)+{+ // Return NULL if the input pointer is NULL+ if (!ptr) {+ return NULL;+ }++ // Get object proxy+ HsQMLObject* object = (HsQMLObject*)ptr;+ HsQMLObjectProxy* proxy = object->proxy();+ proxy->ref(HsQMLObjectProxy::Handle);+ proxy->tryGCLock();++ return (HsQMLObjectHandle*)proxy;+}++extern HsQMLObjectHandle* hsqml_get_object_from_jval(+ HsQMLJValHandle* jvalHndl)+{+ QJSValue* jval = reinterpret_cast<QJSValue*>(jvalHndl);+ return hsqml_get_object_from_pointer(jval->toQObject());+}++extern void hsqml_object_reference_handle(+ HsQMLObjectHandle* hndl,+ int weak)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ proxy->ref(weak ? HsQMLObjectProxy::WeakHandle : HsQMLObjectProxy::Handle);+}++extern void hsqml_finalise_object_handle(+ HsQMLObjectHandle* hndl)+{+ if (hndl) {+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ proxy->deref(HsQMLObjectProxy::Handle);+ }+}++extern void hsqml_finalise_object_weak_handle(+ HsQMLObjectHandle* hndl)+{+ if (hndl) {+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ proxy->deref(HsQMLObjectProxy::WeakHandle);+ }+}++extern void hsqml_fire_signal(+ HsQMLObjectHandle* hndl, int idx, void** args)+{+ HsQMLObjectProxy* proxy = (HsQMLObjectProxy*)hndl;+ HsQMLEngine* engine = proxy->engine();+ // Ignore objects which haven't been marshalled as they are not connected.+ if (engine) {+ // Clear active engine in case the slot code calls back into Haskell.+ Q_ASSERT(gManager->activeEngine() == engine);+ gManager->setActiveEngine(NULL);+ HsQMLObject* obj = proxy->object(engine);+ QMetaObject::activate(obj, proxy->klass()->metaObj(), idx, args);+ }+}++extern HsQMLObjFinaliserHandle* hsqml_create_obj_finaliser(+ HsQMLObjFinaliserCb cb)+{+ return reinterpret_cast<HsQMLObjFinaliserHandle*>(+ new HsQMLObjectFinaliser::Ref(new HsQMLObjectFinaliser(cb)));+}++extern void hsqml_finalise_obj_finaliser(+ HsQMLObjFinaliserHandle* hndl)+{+ HsQMLObjectFinaliser::Ref* fp =+ reinterpret_cast<HsQMLObjectFinaliser::Ref*>(hndl);+ delete fp;+}++extern void hsqml_object_add_finaliser(+ HsQMLObjectHandle* hndl, HsQMLObjFinaliserHandle* fhndl)+{+ HsQMLObjectProxy* proxy = reinterpret_cast<HsQMLObjectProxy*>(hndl);+ proxy->addFinaliser(*reinterpret_cast<HsQMLObjectFinaliser::Ref*>(fhndl));+}
+ cbits/Object.h view
@@ -0,0 +1,102 @@+#ifndef HSQML_OBJECT_H+#define HSQML_OBJECT_H++#include <QtCore/QObject>+#include <QtCore/QAtomicInt>+#include <QtCore/QEvent>+#include <QtCore/QExplicitlySharedDataPointer>+#include <QtCore/QMutex>+#include <QtCore/QVarLengthArray>+#include <QtQml/QJSValue>++#include "hsqml.h"++class HsQMLEngine;+class HsQMLClass;+class HsQMLObject;+class HsQMLObjectProxy;++class HsQMLObjectFinaliser : public QSharedData+{+public:+ typedef QExplicitlySharedDataPointer<HsQMLObjectFinaliser> Ref;++ HsQMLObjectFinaliser(HsQMLObjFinaliserCb);+ ~HsQMLObjectFinaliser();+ void finalise(HsQMLObjectProxy*) const;++private:+ Q_DISABLE_COPY(HsQMLObjectFinaliser);++ HsQMLObjFinaliserCb mFinaliseCb;+};++class HsQMLObjectProxy+{+public:+ HsQMLObjectProxy(HsStablePtr, HsQMLClass*);+ virtual ~HsQMLObjectProxy();+ HsStablePtr haskell() const;+ HsQMLClass* klass() const;+ HsQMLObject* object(HsQMLEngine*);+ void clearObject();+ void tryGCLock();+ void removeGCLock();+ void addFinaliser(const HsQMLObjectFinaliser::Ref&);+ void runFinalisers();+ HsQMLEngine* engine() const;+ enum RefSrc {Handle, WeakHandle, Engine, Variant, Object, Event};+ void ref(RefSrc);+ void deref(RefSrc);++private:+ Q_DISABLE_COPY(HsQMLObjectProxy);++ HsStablePtr mHaskell;+ HsQMLClass* mKlass;+ int mSerial;+ HsQMLObject* volatile mObject;+ QAtomicInt mRefCount;+ QAtomicInt mStrongCount;+ QMutex mFinaliseMutex;+ typedef QVarLengthArray<HsQMLObjectFinaliser::Ref, 1> Finalisers;+ Finalisers mFinalisers;+};++class HsQMLObjectEvent : public QEvent+{+public:+ HsQMLObjectEvent(HsQMLObjectProxy*);+ virtual ~HsQMLObjectEvent();+ void process();++private:+ HsQMLObjectProxy* mProxy;+};++class HsQMLObject : public QObject+{+public:+ HsQMLObject(HsQMLObjectProxy*, HsQMLEngine*);+ virtual ~HsQMLObject();+ virtual const QMetaObject* metaObject() const;+ virtual void* qt_metacast(const char*);+ virtual int qt_metacall(QMetaObject::Call, int, void**);+ void setGCLock();+ void clearGCLock();+ bool isGCLocked() const;+ QJSValue* gcLockVar();+ HsQMLObjectProxy* proxy() const;+ HsQMLEngine* engine() const;++private:+ Q_DISABLE_COPY(HsQMLObject);++ HsQMLObjectProxy* mProxy;+ HsStablePtr mHaskell;+ HsQMLClass* mKlass;+ HsQMLEngine* mEngine;+ QJSValue mGCLock;+};++#endif /*HSQML_OBJECT_H*/
cbits/hsqml.h view
@@ -8,19 +8,18 @@ #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)(); typedef enum { HSQML_EVLOOP_OK = 0, HSQML_EVLOOP_ALREADY_RUNNING,+ HSQML_EVLOOP_POST_SHUTDOWN, HSQML_EVLOOP_WRONG_THREAD, HSQML_EVLOOP_NOT_RUNNING, HSQML_EVLOOP_OTHER_ERROR@@ -37,6 +36,8 @@ extern void hsqml_evloop_notify_jobs(); +extern HsQMLEventLoopStatus hsqml_evloop_shutdown();+ /* String */ typedef char HsQMLStringHandle; @@ -50,29 +51,77 @@ extern void hsqml_deinit_string( HsQMLStringHandle*); -extern UTF16* hsqml_marshal_string(+extern UTF16* hsqml_write_string( int, HsQMLStringHandle*); -extern int hsqml_unmarshal_string(+extern int hsqml_read_string( HsQMLStringHandle*, UTF16**); -/* URL */-typedef char HsQMLUrlHandle;+/* JSValue */+typedef char HsQMLJValHandle; -extern size_t hsqml_get_url_size();+extern size_t hsqml_get_jval_size(); -extern void hsqml_init_url(- HsQMLUrlHandle*);+extern int hsqml_get_jval_typeid(); -extern void hsqml_deinit_url(- HsQMLUrlHandle*);+extern void hsqml_init_jval_null(+ HsQMLJValHandle* hndl, int); -extern void hsqml_marshal_url(- char*, int, HsQMLUrlHandle*);+extern void hsqml_set_jval(+ HsQMLJValHandle*, HsQMLJValHandle*); -extern int hsqml_unmarshal_url(- HsQMLUrlHandle*, char**);+extern void hsqml_deinit_jval(+ HsQMLJValHandle*); +extern void hsqml_init_jval_bool(+ HsQMLJValHandle*, int);++extern int hsqml_is_jval_bool(+ HsQMLJValHandle* hndl);++extern int hsqml_get_jval_bool(+ HsQMLJValHandle* hndl);++extern void hsqml_init_jval_int(+ HsQMLJValHandle*, int);++extern void hsqml_init_jval_double(+ HsQMLJValHandle*, double);++extern int hsqml_is_jval_number(+ HsQMLJValHandle*);++extern int hsqml_get_jval_int(+ HsQMLJValHandle*);++extern double hsqml_get_jval_double(+ HsQMLJValHandle*);++extern void hsqml_init_jval_string(+ HsQMLJValHandle*, HsQMLStringHandle*);++extern int hsqml_is_jval_string(+ HsQMLJValHandle*);++extern void hsqml_get_jval_string(+ HsQMLJValHandle*, HsQMLStringHandle*);++/* Array */+extern void hsqml_init_jval_array(+ HsQMLJValHandle*, unsigned int);++extern int hsqml_is_jval_array(+ HsQMLJValHandle*);++extern unsigned int hsqml_get_jval_array_length(+ HsQMLJValHandle*);++extern void hsqml_jval_array_get(+ HsQMLJValHandle*, unsigned int, HsQMLJValHandle*);++extern void hsqml_jval_array_set(+ HsQMLJValHandle*, unsigned int, HsQMLJValHandle*);+ /* Class */ typedef char HsQMLClassHandle; @@ -81,7 +130,8 @@ extern int hsqml_get_next_class_id(); extern HsQMLClassHandle* hsqml_create_class(- unsigned int*, char*, HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*);+ unsigned int*, unsigned int*, char*,+ HsStablePtr, HsQMLUniformFunc*, HsQMLUniformFunc*); extern void hsqml_finalise_class_handle( HsQMLClassHandle* hndl);@@ -92,35 +142,128 @@ extern HsQMLObjectHandle* hsqml_create_object( HsStablePtr, HsQMLClassHandle*); -extern void hsqml_object_set_active(+extern int hsqml_object_set_active( HsQMLObjectHandle*); extern HsStablePtr hsqml_object_get_hs_typerep( HsQMLObjectHandle*); -extern HsStablePtr hsqml_object_get_haskell(+extern HsStablePtr hsqml_object_get_hs_value( HsQMLObjectHandle*); extern void* hsqml_object_get_pointer( HsQMLObjectHandle*); -extern HsQMLObjectHandle* hsqml_get_object_handle(+extern HsQMLJValHandle* hsqml_object_get_jval(+ HsQMLObjectHandle*);++extern HsQMLObjectHandle* hsqml_get_object_from_pointer( void*); +extern HsQMLObjectHandle* hsqml_get_object_from_jval(+ HsQMLJValHandle*);++extern void hsqml_object_reference_handle(+ HsQMLObjectHandle*, int);+ extern void hsqml_finalise_object_handle( HsQMLObjectHandle*); +extern void hsqml_finalise_object_weak_handle(+ HsQMLObjectHandle*);+ extern void hsqml_fire_signal( HsQMLObjectHandle*, int, void**); +/* Object Finaliser */+typedef char HsQMLObjFinaliserHandle;++typedef void (*HsQMLObjFinaliserCb)(HsQMLObjectHandle*);++extern HsQMLObjFinaliserHandle* hsqml_create_obj_finaliser(+ HsQMLObjFinaliserCb);++extern void hsqml_finalise_obj_finaliser(+ HsQMLObjFinaliserHandle*);++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*,- HsQMLUrlHandle*,- int,- int, HsQMLStringHandle*,+ HsQMLStringHandle**,+ HsQMLStringHandle**, HsQMLTrivialCb stopCb);++extern void hsqml_kill_engine(+ HsQMLEngineHandle*);++extern void hsqml_finalise_engine_handle(+ HsQMLEngineHandle*);++/* Canvas */+typedef char HsQMLGLDelegateHandle;++typedef enum {+ HSQML_GL_DESKTOP,+ HSQML_GL_ES+} HsQMLGLCanvasType;++typedef void (*HsQMLGLSetupCb)(+ HsQMLGLCanvasType, int, int);++typedef void (*HsQMLGLCleanupCb)();++typedef int (*HsQMLGLSyncCb)(+ HsQMLJValHandle*);++typedef void (*HsQMLGLPaintCb)(+ float*, float, float);++typedef void (*HsQMLGLMakeCallbacksCb)(+ HsQMLGLSetupCb*,+ HsQMLGLCleanupCb*,+ HsQMLGLSyncCb*,+ HsQMLGLPaintCb*);++extern HsQMLGLDelegateHandle* hsqml_create_gldelegate();++extern void hsqml_finalise_gldelegate_handle(+ HsQMLGLDelegateHandle*);++extern void hsqml_gldelegate_setup(+ HsQMLGLDelegateHandle*,+ HsQMLGLMakeCallbacksCb);++extern void hsqml_gldelegate_to_jval(+ HsQMLGLDelegateHandle*,+ HsQMLJValHandle*);++extern int hsqml_gldelegate_from_jval(+ HsQMLGLDelegateHandle*,+ HsQMLJValHandle*); #ifdef __cplusplus }
hsqml.cabal view
@@ -1,21 +1,34 @@+cabal-version: 3.8 Name: hsqml-Version: 0.2.0.3-Cabal-version: >= 1.14+Version: 0.3.7.0 Build-type: Custom-License: BSD3+License: BSD-3-Clause License-file: LICENSE-Copyright: (c) 2010-2014 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/-Category: Graphics+Category: Graphics, GUI Synopsis: Haskell binding for Qt Quick-Extra-source-files: CHANGELOG cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs++tested-with: GHC ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.2 || ==9.12.2++Extra-source-files:+ README.md+ cbits/*.cpp cbits/*.h test/Graphics/QML/Test/*.hs++Extra-doc-files:+ CHANGELOG+ Description:- A Haskell binding for Qt Quick.+ 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. - General documentation is present in the 'Graphics.QML' module.+Source-repository head+ type: git+ location: https://github.com/prolic/HsQML Flag UsePkgConfig Description:@@ -32,76 +45,147 @@ Force enable GHCi workaround library if not using shared libraries. Default: True +Flag UseExitHook+ Description:+ 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.*,- network >= 2.3 && < 2.5,- text >= 0.11 && < 1.2,- tagged >= 0.4 && < 0.8,- transformers >= 0.2 && < 0.4+ 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 Other-modules: Graphics.QML.Internal.BindPrim+ Graphics.QML.Internal.BindCanvas Graphics.QML.Internal.BindObj Graphics.QML.Internal.BindCore Graphics.QML.Internal.JobQueue Graphics.QML.Internal.Marshal Graphics.QML.Internal.MetaObj Graphics.QML.Internal.Objects+ Graphics.QML.Internal.Types Hs-source-dirs: src- C-sources:- cbits/HsQMLClass.cpp- cbits/HsQMLEngine.cpp- cbits/HsQMLIntrinsics.cpp- cbits/HsQMLManager.cpp- cbits/HsQMLObject.cpp- cbits/HsQMLWindow.cpp+ 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/HsQMLEngine.h- cbits/HsQMLManager.h- cbits/HsQMLWindow.h+ 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: QtCore4, QtGui4, QtScript4, QtDeclarative4, stdc+++ Extra-libraries:+ 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 QtScript QtDeclarative+ Frameworks: QtCore QtGui QtWidgets QtNetwork QtQml QtQuick+ Include-dirs: /QT_ROOT/include+ CC-options: -F /QT_ROOT/lib+ Extra-framework-dirs: /QT_ROOT/lib else Pkgconfig-depends:- QtScript >= 4.7 && < 5.0, QtDeclarative >= 4.7 && < 5.0+ 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,- network >= 2.3 && < 2.5,- text >= 0.11 && < 1.2,- tagged >= 0.4 && < 0.8,- QuickCheck >= 2.4 && < 2.7,- hsqml == 0.2.*+ 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: -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.hs view
@@ -16,30 +16,14 @@ The 'Graphics.QML.Objects' module allows you to define your own custom object types which can be marshalled between Haskell and JavaScript. -}--- * Script-side APIs-{-|-The @window@ object provides the following methods and properties to QML-scripts.--/Properties/--[@source : url@] URL for the Window's QML document.--[@title : string@] Window title.--[@visible : bool@] Window visibility.--/Methods/--[@close()@] Closes the window.-- -} -- * Graphics.QML module Graphics.QML.Engine, module Graphics.QML.Marshal,- module Graphics.QML.Objects+ module Graphics.QML.Objects,+ module Graphics.QML.Objects.Weak ) where import Graphics.QML.Engine import Graphics.QML.Marshal import Graphics.QML.Objects+import Graphics.QML.Objects.Weak
+ src/Graphics/QML/Canvas.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE+ ScopedTypeVariables,+ TypeFamilies,+ FlexibleInstances+ #-}++{-| Facility for drawing OpenGL graphics into the QML scenegraph.++To use this facility, you must place a @HaskellCanvas@ item into your+QML scene. This item can be imported from the @HsQML.Canvas 1.0@ module using+an @import@ statement in your QML script. It has several properties which can+be set from QML:++[@displayMode@] Specifies how the canvas is rendered with respect to the+rest of the scene. Possible values are:++ [@HaskellCanvas.Above@] The canvas shares a buffer with the scenegraph+ and is painted top of other items.+ [@HaskellCanvas.Inline@] The canvas has its own framebuffer object and the+ contents of this buffer are painted inline with other items (default).+ [@HaskellCanvas.Below@] The canvas shares a buffer with the scenegraph+ and is painted underneath other items.++[@canvasWidth@] Width of the framebuffer object in pixels. Defaults to the+item width.+[@canvasHeight@] Height of the framebuffer object in pixels. Defaults to the+item height.+[@delegate@] A marshalled 'OpenGLDelegate' value which specifies the Haskell+functions used to render the canvas.+[@model@] A value passed to delegate's paint function. The canvas is+repainted whenever this value changes.+[@status@] Either @HaskellCanvas.Okay@ or an error code (read only).++The @HsQML.Canvas 1.0@ module also contains another type of item called+@OpenGLConextControl@ which can be used to configure the OpenGL context used by+your windows. When placed inside a QML window, it has several properties which+when read return the current state of that window's OpenGL context, and when+written to cause the window's context to be reconfigured with a request for the+supplied setting. Note that as reconfiguring the context may cause a visible+window to dis- and re-appear, it's recommended to supply the desired settings+at startup or otherwise before the corresponding window is made visible.+Available properties are as below:++[@majorVersion@] Major component of the OpenGL version.+[@minorVersion@] Minor component of the OpenGL version.+[@contextType@] The type of OpenGL context. One of:+@OpenGLContextControl.UnknownType@, @OpenGLContextControl.OpenGL@, or+@OpenGLContextControl.OpenGLES@.+[@contextProfile@] The OpenGL context's profile. One of:+@OpenGLContextControl.NoProfile@, @OpenGLContextControl.CoreProfile@, or+@OpenGLContextControl.CompatibilityProfile@.+[@deprecatedFunctions@] True if deprecated functions are available.+[@depthBufferSize@] Depth buffer size in bits.+[@stencilBufferSize@] Stencil buffer size in bits.+[@when@] Any changes to the OpenGL context while this property is set to false+will be deferred until it is true again. The default value is true.+-}+module Graphics.QML.Canvas (+ OpenGLDelegate,+ newOpenGLDelegate,+ OpenGLType (+ OpenGLDesktop,+ OpenGLES),+ OpenGLSetup,+ openGLType,+ openGLMajor,+ openGLMinor,+ OpenGLPaint,+ OpenGLPaint',+ setupData,+ modelData,+ matrixPtr,+ itemWidth,+ itemHeight+) where++import Graphics.QML.Internal.BindCanvas+import Graphics.QML.Internal.BindPrim+import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Types+import Graphics.QML.Marshal++import Data.IORef+import Data.Maybe+import Data.Tagged+import Control.Monad.Trans.Maybe+import Foreign.Ptr (Ptr)+import Foreign.C.Types (CFloat)++-- | Delegate for painting OpenGL graphics.+newtype OpenGLDelegate = OpenGLDelegate HsQMLGLDelegateHandle++instance Marshal OpenGLDelegate where+ type MarshalMode OpenGLDelegate c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \_ ptr -> MaybeT $ do+ hndl <- hsqmlCreateGldelegate+ fromJVal Weak (hsqmlGldelegateFromJval hndl)+ (const . return $ OpenGLDelegate hndl) ptr,+ mWithJVal_ = \(OpenGLDelegate hndl) f ->+ withJVal (flip hsqmlGldelegateToJval) hndl f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}++-- | Represents the type of an OpenGL context.+data OpenGLType+ -- | Desktop OpenGL context.+ = OpenGLDesktop+ -- | OpenGL ES context.+ | OpenGLES+ deriving (Eq, Show)++mapGLType :: HsQMLGLCanvasType -> OpenGLType+mapGLType HsqmlGlDesktop = OpenGLDesktop+mapGLType HsqmlGlEs = OpenGLES++-- | Encapsulates parameters for OpenGL setup.+data OpenGLSetup = OpenGLSetup {+ -- | Type of OpenGL context.+ openGLType :: OpenGLType,+ -- | Major version number of OpenGL context.+ openGLMajor :: Int,+ -- | Minor version number of OpenGL context.+ openGLMinor :: Int+}++-- | Encapsulates parameters for OpenGL paint.+data OpenGLPaint s m = OpenGLPaint {+ -- | Gets the setup state.+ setupData :: s,+ -- | Gets the active model.+ modelData :: m,+ -- | Pointer to a 4 by 4 matrix which transform coordinates in the range+ -- (-1, -1) to (1, 1) on to the target rectangle in the scene.+ matrixPtr :: Ptr CFloat,+ -- | Width of the canvas item in its local coordinate system.+ itemWidth :: Float,+ -- | Height of the canvas item in its local coordinate system.+ itemHeight :: Float+}++-- | Specialised version of `OpenGLPaint` with no model.+type OpenGLPaint' s = OpenGLPaint s Ignored++newOpenGLCallbacks :: (Marshal m, CanGetFrom m ~ Yes) =>+ (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->+ CallbacksFactory+newOpenGLCallbacks setupFn paintFn cleanupFn = do+ iRef <- newIORef Nothing+ mRef <- newIORef Nothing+ let setupCb ctype major minor = do+ iVal <- setupFn $ OpenGLSetup+ (mapGLType $ cIntToEnum ctype)+ (fromIntegral major) (fromIntegral minor)+ writeIORef iRef $ Just iVal+ cleanupCb = do+ iVal <- readIORef iRef+ cleanupFn $ fromJust iVal+ syncCb ptr = do+ mVal <- runMaybeT $ mFromJVal Strong ptr+ writeIORef mRef mVal+ return $ if isJust mVal then 1 else 0+ paintCb mPtr w h = do+ iVal <- readIORef iRef+ mVal <- readIORef mRef+ paintFn $ OpenGLPaint+ (fromJust iVal) (fromJust mVal)+ mPtr (realToFrac w) (realToFrac h)+ return (setupCb, cleanupCb, syncCb, paintCb)++-- | Creates a new 'OpenGLDelegate' from setup, paint, and cleanup functions.+newOpenGLDelegate :: (Marshal m, CanGetFrom m ~ Yes) =>+ (OpenGLSetup -> IO i) -> (OpenGLPaint i m -> IO ()) -> (i -> IO ()) ->+ IO OpenGLDelegate+newOpenGLDelegate setupFn paintFn cleanupFn = do+ hndl <- hsqmlCreateGldelegate+ hsqmlGldelegateSetup hndl (newOpenGLCallbacks setupFn paintFn cleanupFn)+ return $ OpenGLDelegate hndl
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
@@ -7,134 +7,160 @@ -- | Functions for starting QML engines, displaying content in a window. module Graphics.QML.Engine ( -- * Engines- InitialWindowState(- ShowWindow,- ShowWindowWithTitle,- HideWindow), EngineConfig( EngineConfig,- initialURL,- initialWindowState,- contextObject),+ initialDocument,+ contextObject,+ importPaths,+ 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(), - -- * Utilities- filePathToURI+ -- * Document Paths+ DocumentPath(),+ fileDocument,+ uriDocument ) where import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.BindCore-import Graphics.QML.Marshal+import Graphics.QML.Marshal () import Graphics.QML.Objects import Control.Applicative import Control.Concurrent-import Control.Concurrent.MVar 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.Maybe-import Data.Traversable as T+import Data.Traversable (sequenceA) import Data.Typeable-import System.FilePath (isAbsolute, splitDirectories, pathSeparators)-import Network.URI (URI(URI), URIAuth(URIAuth), nullURI, uriPath)---- | Specifies the intial state of the display window.-data InitialWindowState- -- | A visible window should be created for the initial document with a- -- default title.- = ShowWindow- -- | A visible window should be created for the initial document with the- -- given title.- | ShowWindowWithTitle String- -- | A window should be created for the initial document, but it will remain- -- hidden until made visible by the QML script.- | HideWindow+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. data EngineConfig = EngineConfig {- -- | URL for the first QML document to be loaded.- initialURL :: URI,- -- | Window state for the initial QML document.- initialWindowState :: InitialWindowState,+ -- | Path to the first QML document to be loaded.+ initialDocument :: DocumentPath, -- | Context 'Object' made available to QML script code.- contextObject :: Maybe AnyObjRef+ contextObject :: Maybe AnyObjRef,+ -- | Additional search paths for QML modules+ importPaths :: [FilePath],+ -- | Additional search paths for QML native plugins+ 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 defaultEngineConfig = EngineConfig {- initialURL = nullURI {uriPath = "main.qml"},- initialWindowState = ShowWindow,- contextObject = Nothing+ initialDocument = DocumentPath "main.qml",+ contextObject = Nothing,+ importPaths = [],+ pluginPaths = [],+ iconPath = Nothing } -isWindowShown :: InitialWindowState -> Bool-isWindowShown ShowWindow = True-isWindowShown (ShowWindowWithTitle _) = True-isWindowShown HideWindow = False--getWindowTitle :: InitialWindowState -> Maybe String-getWindowTitle (ShowWindowWithTitle t) = Just t-getWindowTitle _ = 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- url = initialURL config- state = initialWindowState config- showWin = isWindowShown state- maybeTitle = getWindowTitle state- setTitle = isJust maybeTitle- titleStr = fromMaybe "" maybeTitle- hndl <- T.sequence $ fmap mHsToObj $ obj- mHsToAlloc url $ \urlPtr -> do- mHsToAlloc titleStr $ \titlePtr -> do- hsqmlCreateEngine hndl urlPtr showWin setTitle titlePtr stopCb- return Engine+ DocumentPath res = initialDocument config+ impPaths = importPaths config+ plugPaths = pluginPaths config+ stopCb = putMVar finishVar () --- | 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 ())+ ctxHndl <- sequenceA $ fmap mToHndl obj+ engHndl <- mWithCVal (T.pack res) $ \resPtr ->+ withManyArray0 mWithCVal (map T.pack impPaths) nullPtr $ \impPtr ->+ withManyArray0 mWithCVal (map T.pack plugPaths) nullPtr $ \plugPtr ->+ hsqmlCreateEngine ctxHndl (HsQMLStringHandle $ castPtr resPtr)+ (castPtr impPtr) (castPtr plugPtr) stopCb + case iconPath config of+ Just path -> liftIO $ withCString path setWindowIcon+ Nothing -> return ()++ return $ Engine engHndl finishVar++withMany :: (a -> (b -> m c) -> m c) -> [a] -> ([b] -> m c) -> m c+withMany func as cont =+ let rec (a:as') bs = func a (\b -> rec as' (bs . (b:)))+ rec [] bs = cont $ bs []+ in rec as id++withManyArray0 :: Storable b =>+ (a -> (b -> IO c) -> IO c) -> [a] -> b -> (Ptr b -> IO c) -> IO c+withManyArray0 func as term cont =+ withMany func as $ \ptrs -> withArray0 term ptrs cont++-- | 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 $ do- 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@@ -148,7 +174,7 @@ newtype RunQML a = RunQML (IO a) deriving (Functor, Applicative, Monad) instance MonadIO RunQML where- liftIO io = RunQML io+ liftIO = RunQML -- | This function enters the Qt event loop and executes the supplied function -- in the 'RunQML' monad on a new unbound thread. The event loop will continue@@ -162,15 +188,32 @@ -- 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 ret <- try runFn case ret of Left ex -> putMVar finishVar $ throwIO (ex :: SomeException)- Right ret -> putMVar finishVar $ return ret+ Right ret' -> putMVar finishVar $ return ret' hsqmlEvloopRelease yieldCb = if rtsSupportsBoundThreads then Nothing@@ -183,7 +226,7 @@ finFn tryRunInBoundThread :: IO a -> IO a-tryRunInBoundThread action = do+tryRunInBoundThread action = if rtsSupportsBoundThreads then runInBoundThread action else action@@ -203,9 +246,81 @@ 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+-- 'runEventLoop' is first called and remains initialised afterwards so that+-- the event loop can be reentered if desired (e.g. when using GHCi). Once+-- shut down, the framework cannot be reinitialised.+--+-- It is recommended that you call this function at the end of your program as+-- this library will try, but cannot guarantee in all configurations to be able+-- to shut it down for you. Failing to shutdown the framework has been known to+-- intermittently cause crashes on process exit on some platforms.+--+-- This function must be called from the event loop thread and the event loop+-- must not be running at the time otherwise an 'EventLoopException' will be+-- thrown.+shutdownQt :: IO ()+shutdownQt = do+ status <- hsqmlEvloopShutdown+ case statusException status of+ Just ex -> throw ex+ Nothing -> return ()+ statusException :: HsQMLEventLoopStatus -> Maybe EventLoopException statusException HsqmlEvloopOk = Nothing statusException HsqmlEvloopAlreadyRunning = Just EventLoopAlreadyRunning+statusException HsqmlEvloopPostShutdown = Just EventLoopPostShutdown statusException HsqmlEvloopWrongThread = Just EventLoopWrongThread statusException HsqmlEvloopNotRunning = Just EventLoopNotRunning statusException _ = Just EventLoopOtherError@@ -213,6 +328,7 @@ -- | Exception type used to report errors pertaining to the event loop. data EventLoopException = EventLoopAlreadyRunning+ | EventLoopPostShutdown | EventLoopWrongThread | EventLoopNotRunning | EventLoopOtherError@@ -220,18 +336,23 @@ instance Exception EventLoopException --- | Convenience function for converting local file paths into URIs.-filePathToURI :: FilePath -> URI-filePathToURI fp =+-- | Path to a QML document file.+newtype DocumentPath = DocumentPath String++-- | Converts a local file path into a 'DocumentPath'.+fileDocument :: FilePath -> DocumentPath+fileDocument fp = let ds = splitDirectories fp- abs = isAbsolute fp+ isAbs = isAbsolute fp fixHead = (\cs -> if null cs then [] else '/':cs) .- takeWhile (\c -> not $ c `elem` pathSeparators)+ takeWhile (`notElem` pathSeparators) mapHead _ [] = [] mapHead f (x:xs) = f x : xs afp = intercalate "/" $ mapHead fixHead ds rfp = intercalate "/" ds- in if abs- then URI "file:" (Just $ URIAuth "" "" "") afp "" ""- else URI "" Nothing rfp "" ""+ in DocumentPath $ if isAbs then "file://" ++ afp else rfp++-- | Converts a URI string into a 'DocumentPath'.+uriDocument :: String -> DocumentPath+uriDocument = DocumentPath
+ src/Graphics/QML/Internal/BindCanvas.chs view
@@ -0,0 +1,89 @@+{-# LANGUAGE+ ForeignFunctionInterface+ #-}++module Graphics.QML.Internal.BindCanvas where++{#import Graphics.QML.Internal.BindPrim #}++import Foreign.C.Types+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable++#include "hsqml.h"++--+-- GL Delegate+--++{#pointer *HsQMLGLDelegateHandle as ^ foreign newtype #}++type SetupCb = CInt -> CInt -> CInt -> IO ()+type CleanupCb = IO ()+type SyncCb = HsQMLJValHandle -> IO CInt+type PaintCb = Ptr CFloat -> CFloat -> CFloat -> IO ()+type MakeCb = Ptr (FunPtr SetupCb) -> Ptr (FunPtr CleanupCb) ->+ Ptr (FunPtr SyncCb) -> Ptr (FunPtr PaintCb) -> IO ()+type CallbacksFactory = IO (SetupCb, CleanupCb, SyncCb, PaintCb)++{#enum HsQMLGLCanvasType as ^ {underscoreToCase} #}++foreign import ccall "wrapper"+ marshalSetupCb :: SetupCb -> IO (FunPtr SetupCb)++foreign import ccall "wrapper"+ marshalCleanupCb :: CleanupCb -> IO (FunPtr CleanupCb)++foreign import ccall "wrapper" + marshalSyncCb :: SyncCb -> IO (FunPtr SyncCb)++foreign import ccall "wrapper" + marshalPaintCb :: PaintCb -> IO (FunPtr PaintCb)++foreign import ccall "wrapper"+ marshalMakeCb :: MakeCb -> IO (FunPtr MakeCb)++withCallbacksFactory :: CallbacksFactory -> (FunPtr MakeCb -> IO a) -> IO a+withCallbacksFactory factory with = do+ let makeFn setupPtrFPtr cleanupPtrFPtr syncPtrFPtr paintPtrFPtr = do+ (setupFn, cleanupFn, syncFn, paintFn) <- factory+ setupFPtr <- marshalSetupCb setupFn+ poke setupPtrFPtr setupFPtr+ cleanupFPtr <- marshalCleanupCb cleanupFn+ poke cleanupPtrFPtr cleanupFPtr+ syncFPtr <- marshalSyncCb syncFn+ poke syncPtrFPtr syncFPtr+ paintFPtr <- marshalPaintCb paintFn+ poke paintPtrFPtr paintFPtr+ makeFPtr <- marshalMakeCb makeFn+ with makeFPtr++foreign import ccall "hsqml.h &hsqml_finalise_gldelegate_handle"+ hsqmlFinaliseGldelegateHandlePtr ::+ FunPtr (Ptr HsQMLGLDelegateHandle -> IO ())++newGLDelegateHandle :: Ptr HsQMLGLDelegateHandle -> IO HsQMLGLDelegateHandle+newGLDelegateHandle p = do+ fp <- newForeignPtr hsqmlFinaliseGldelegateHandlePtr p+ return $ HsQMLGLDelegateHandle fp++{#fun unsafe hsqml_create_gldelegate as ^+ {} ->+ `HsQMLGLDelegateHandle' newGLDelegateHandle* #}++{#fun unsafe hsqml_gldelegate_setup as ^+ {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+ withCallbacksFactory* `CallbacksFactory'} ->+ `()' #}++{#fun unsafe hsqml_gldelegate_to_jval as ^+ {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+ id `HsQMLJValHandle'} ->+ `()' #}++{#fun unsafe hsqml_gldelegate_from_jval as ^+ {withHsQMLGLDelegateHandle* `HsQMLGLDelegateHandle',+ id `HsQMLJValHandle'} ->+ `Bool' toBool #}
src/Graphics/QML/Internal/BindCore.chs view
@@ -5,13 +5,13 @@ module Graphics.QML.Internal.BindCore where +{#import Graphics.QML.Internal.BindPrim #} {#import Graphics.QML.Internal.BindObj #} import Foreign.C.Types-import Foreign.C.String-import Foreign.Marshal.Utils+import Foreign.ForeignPtr+import Foreign.Marshal.Utils (fromBool, toBool) import Foreign.Ptr-import Foreign.StablePtr #include <HsFFI.h> @@ -33,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" @@ -47,9 +70,6 @@ {#enum HsQMLEventLoopStatus as ^ {underscoreToCase} #} -cIntToEnum :: Enum a => CInt -> a-cIntToEnum = toEnum . fromIntegral- {#fun hsqml_evloop_run as ^ {withTrivialCb* `TrivialCb', withTrivialCb* `TrivialCb',@@ -68,13 +88,30 @@ {} -> `()' #} +{#fun unsafe hsqml_evloop_shutdown as ^+ {} ->+ `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',- castPtr `Ptr ()',- fromBool `Bool',- fromBool `Bool',- castPtr `Ptr ()',+ 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
@@ -4,12 +4,16 @@ module Graphics.QML.Internal.BindObj where -import Control.Exception (bracket_)-import Data.Typeable+import Graphics.QML.Internal.Types+{#import Graphics.QML.Internal.BindPrim #}++import Control.Exception (bracket)+import Control.Monad (void) 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"@@ -28,8 +32,6 @@ {} -> `CInt' id #} -type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()- foreign import ccall "wrapper" marshalFunc :: UniformFunc -> IO (FunPtr UniformFunc) @@ -48,8 +50,9 @@ {#fun unsafe hsqml_create_class as ^ {id `Ptr CUInt',+ id `Ptr CUInt', id `Ptr CChar',- marshalStable* `TypeRep',+ marshalStable* `ClassInfo', id `Ptr (FunPtr UniformFunc)', id `Ptr (FunPtr UniformFunc)'} -> `Maybe HsQMLClassHandle' newClassHandle* #}@@ -64,6 +67,9 @@ foreign import ccall "hsqml.h &hsqml_finalise_object_handle" hsqmlFinaliseObjectHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ()) +foreign import ccall "hsqml.h &hsqml_finalise_object_weak_handle"+ hsqmlFinaliseObjectWeakHandlePtr :: FunPtr (Ptr (HsQMLObjectHandle) -> IO ())+ newObjectHandle :: Ptr HsQMLObjectHandle -> IO HsQMLObjectHandle newObjectHandle p = do fp <- newForeignPtr hsqmlFinaliseObjectHandlePtr p@@ -71,7 +77,7 @@ isNullObjectHandle :: HsQMLObjectHandle -> Bool isNullObjectHandle (HsQMLObjectHandle fp) =- nullPtr == unsafeForeignPtrToPtr fp+ nullPtr == UnsafeFPtr.unsafeForeignPtrToPtr fp {#fun unsafe hsqml_create_object as ^ {marshalStable* `a',@@ -80,33 +86,82 @@ {#fun unsafe hsqml_object_set_active as ^ {withMaybeHsQMLObjectHandle* `Maybe HsQMLObjectHandle'} ->- `()' #}+ `Bool' toBool #} withActiveObject :: HsQMLObjectHandle -> IO () -> IO () withActiveObject hndl action =- bracket_+ bracket (hsqmlObjectSetActive $ Just hndl)- (hsqmlObjectSetActive Nothing)- action+ (\ok -> if ok then void $ hsqmlObjectSetActive Nothing else return ())+ (\ok -> if ok then action else return ()) -{#fun unsafe hsqml_object_get_haskell as ^+{#fun unsafe hsqml_object_get_hs_typerep as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `a' fromStable* #}+ `ClassInfo' fromStable* #} -{#fun unsafe hsqml_object_get_hs_typerep as ^+{#fun unsafe hsqml_object_get_hs_value as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->- `TypeRep' fromStable* #}+ `a' fromStable* #} {#fun unsafe hsqml_object_get_pointer as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle'} -> `Ptr ()' id #} -{#fun unsafe hsqml_get_object_handle as ^+{#fun unsafe hsqml_object_get_jval as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle'} ->+ `HsQMLJValHandle' id #}++{#fun unsafe hsqml_get_object_from_pointer as ^ {id `Ptr ()'} -> `HsQMLObjectHandle' newObjectHandle* #} +{#fun unsafe hsqml_get_object_from_jval as ^+ {id `HsQMLJValHandle'} ->+ `HsQMLObjectHandle' newObjectHandle* #}++{#fun unsafe hsqml_object_reference_handle as ^+ {id `Ptr HsQMLObjectHandle',+ fromBool `Bool'} ->+ `()' #}++copyObjectHandle :: HsQMLObjectHandle -> Bool -> IO HsQMLObjectHandle+copyObjectHandle (HsQMLObjectHandle fp) weak = do+ withForeignPtr fp $ \p -> do+ hsqmlObjectReferenceHandle p weak+ fp' <- newForeignPtr final p+ return $ HsQMLObjectHandle fp'+ where final = if weak+ then hsqmlFinaliseObjectWeakHandlePtr+ else hsqmlFinaliseObjectHandlePtr+ {#fun hsqml_fire_signal as ^ {withHsQMLObjectHandle* `HsQMLObjectHandle', `Int', id `Ptr (Ptr ())'} -> `()' #}++{#pointer *HsQMLObjFinaliserHandle as ^ foreign newtype #}++foreign import ccall "hsqml.h &hsqml_finalise_obj_finaliser"+ hsqmlFinaliseObjFinaliserPtr :: FunPtr (Ptr HsQMLObjFinaliserHandle -> IO ())++type ObjFinaliserFunc = Ptr HsQMLObjectHandle -> IO ()++foreign import ccall "wrapper" + marshalObjFinaliser :: ObjFinaliserFunc -> IO (FunPtr ObjFinaliserFunc)++newObjFinaliserHandle ::+ Ptr HsQMLObjFinaliserHandle -> IO HsQMLObjFinaliserHandle+newObjFinaliserHandle p = do+ fp <- newForeignPtr hsqmlFinaliseObjFinaliserPtr p+ return $ HsQMLObjFinaliserHandle fp++{#fun unsafe hsqml_create_obj_finaliser as ^+ {id `FunPtr ObjFinaliserFunc'} ->+ `HsQMLObjFinaliserHandle' newObjFinaliserHandle* #}++{#fun unsafe hsqml_object_add_finaliser as ^+ {withHsQMLObjectHandle* `HsQMLObjectHandle',+ withHsQMLObjFinaliserHandle* `HsQMLObjFinaliserHandle'} ->+ `()' #}+
src/Graphics/QML/Internal/BindPrim.chs view
@@ -4,15 +4,22 @@ module Graphics.QML.Internal.BindPrim where +import Graphics.QML.Internal.Types+ import Foreign.C.Types+import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils import Foreign.Ptr import System.IO.Unsafe #include "hsqml.h" -cIntConv :: (Integral a, Integral b) => a -> b-cIntConv = fromIntegral+cIntToEnum :: Enum a => CInt -> a+cIntToEnum = toEnum . fromIntegral +enumToCInt :: Enum a => a -> CInt+enumToCInt = fromIntegral . fromEnum+ -- -- String --@@ -24,7 +31,7 @@ `Int' fromIntegral #} hsqmlStringSize :: Int-hsqmlStringSize = unsafePerformIO $ hsqmlGetStringSize+hsqmlStringSize = unsafeDupablePerformIO $ hsqmlGetStringSize {#fun unsafe hsqml_init_string as ^ {id `HsQMLStringHandle'} ->@@ -34,44 +41,152 @@ {id `HsQMLStringHandle'} -> `()' #} -{#fun unsafe hsqml_marshal_string as ^+{#fun unsafe hsqml_write_string as ^ {`Int', id `HsQMLStringHandle'} -> `Ptr CUShort' id #} -{#fun unsafe hsqml_unmarshal_string as ^+{#fun unsafe hsqml_read_string as ^ {id `HsQMLStringHandle', id `Ptr (Ptr CUShort)'} -> `Int' #} +withStrHndl :: (HsQMLStringHandle -> IO b) -> IO b+withStrHndl contFn =+ allocaBytes hsqmlStringSize $ \ptr -> do+ let str = HsQMLStringHandle ptr+ hsqmlInitString str+ ret <- contFn str+ hsqmlDeinitString str+ return ret+ ----- URL+-- JSValue -- -{#pointer *HsQMLUrlHandle as ^ newtype #}+{#pointer *HsQMLJValHandle as ^ newtype #} -{#fun unsafe hsqml_get_url_size as ^+{#fun unsafe hsqml_get_jval_size as ^ {} -> `Int' fromIntegral #} -hsqmlUrlSize :: Int-hsqmlUrlSize = unsafePerformIO $ hsqmlGetUrlSize+hsqmlJValSize :: Int+hsqmlJValSize = unsafeDupablePerformIO $ hsqmlGetJvalSize -{#fun unsafe hsqml_init_url as ^- {id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_get_jval_typeid as ^+ {} ->+ `Int' fromIntegral #}++hsqmlJValTypeId :: Int+hsqmlJValTypeId = unsafeDupablePerformIO $ hsqmlGetJvalTypeid++{#fun unsafe hsqml_init_jval_null as ^+ {id `HsQMLJValHandle',+ fromBool `Bool'} -> `()' #} -{#fun unsafe hsqml_deinit_url as ^- {id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_deinit_jval as ^+ {id `HsQMLJValHandle'} -> `()' #} -{#fun unsafe hsqml_marshal_url as ^- {id `Ptr CChar',- `Int',- id `HsQMLUrlHandle'} ->+{#fun unsafe hsqml_set_jval as ^+ {id `HsQMLJValHandle',+ id `HsQMLJValHandle'} -> `()' #} -{#fun unsafe hsqml_unmarshal_url as ^- {id `HsQMLUrlHandle',- id `Ptr (Ptr CChar)'} ->- `Int' #}+{#fun unsafe hsqml_init_jval_bool as ^+ {id `HsQMLJValHandle',+ fromBool `Bool'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_bool as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_bool as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_init_jval_int as ^+ {id `HsQMLJValHandle',+ id `CInt'} ->+ `()' #}++{#fun unsafe hsqml_init_jval_double as ^+ {id `HsQMLJValHandle',+ id `CDouble'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_number as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_int as ^+ {id `HsQMLJValHandle'} ->+ `CInt' id #}++{#fun unsafe hsqml_get_jval_double as ^+ {id `HsQMLJValHandle'} ->+ `CDouble' id #}++{#fun unsafe hsqml_init_jval_string as ^+ {id `HsQMLJValHandle',+ id `HsQMLStringHandle'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_string as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_string as ^+ {id `HsQMLJValHandle',+ id `HsQMLStringHandle'} ->+ `()' #}++fromJVal ::+ Strength -> (HsQMLJValHandle -> IO Bool) -> (HsQMLJValHandle -> IO a) ->+ HsQMLJValHandle -> IO (Maybe a)+fromJVal Strong _ getFn jval =+ fmap Just $ getFn jval+fromJVal Weak isFn getFn jval = do+ is <- isFn jval+ if is then fmap Just $ getFn jval else return Nothing++withJVal ::+ (HsQMLJValHandle -> a -> IO ()) -> a -> (HsQMLJValHandle -> IO b) -> IO b+withJVal initFn val contFn =+ allocaBytes hsqmlJValSize $ \ptr -> do+ let jval = HsQMLJValHandle ptr+ initFn jval val+ ret <- contFn jval+ hsqmlDeinitJval jval+ return ret++--+-- Array+--++{#fun unsafe hsqml_init_jval_array as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int'} ->+ `()' #}++{#fun unsafe hsqml_is_jval_array as ^+ {id `HsQMLJValHandle'} ->+ `Bool' toBool #}++{#fun unsafe hsqml_get_jval_array_length as ^+ {id `HsQMLJValHandle'} ->+ `Int' fromIntegral #}++{#fun unsafe hsqml_jval_array_get as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int',+ id `HsQMLJValHandle'} ->+ `()' #}++{#fun unsafe hsqml_jval_array_set as ^+ {id `HsQMLJValHandle',+ fromIntegral `Int',+ id `HsQMLJValHandle'} ->+ `()' #}
src/Graphics/QML/Internal/Marshal.hs view
@@ -1,127 +1,255 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies,- FlexibleContexts,- FlexibleInstances, Rank2Types #-} module Graphics.QML.Internal.Marshal where +import Graphics.QML.Internal.Types+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 import Foreign.Ptr import System.IO --- | Represents a QML type name.-newtype TypeName = TypeName {- typeName :: String-}- type ErrIO a = MaybeT IO a runErrIO :: ErrIO a -> IO () runErrIO m = do- r <- runMaybeT m- if isNothing r- then hPutStrLn stderr "Warning: Marshalling error."- else return ()+ 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 -type MTypeNameFunc t = Tagged t TypeName-type MValToHsFunc t = Ptr () -> ErrIO t-type MHsToValFunc t = t -> Ptr () -> IO ()-type MHsToAllocFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b)+tyInt, tyDouble, tyString, tyObject, tyVoid, tyJSValue :: TypeId+tyInt = TypeId 2+tyDouble = TypeId 6+tyString = TypeId 10+tyObject = TypeId 39+tyVoid = TypeId 43+tyJSValue = TypeId hsqmlJValTypeId +type MTypeCValFunc t = Tagged t TypeId+type MFromCValFunc t = Ptr () -> ErrIO t+type MToCValFunc t = t -> Ptr () -> IO ()+type MWithCValFunc t = (forall b. t -> (Ptr () -> IO b) -> IO b)++type MFromJValFunc t = Strength -> HsQMLJValHandle -> ErrIO t+type MWithJValFunc t = (forall b. t -> (HsQMLJValHandle -> IO b) -> IO b)++type MFromHndlFunc t = HsQMLObjectHandle -> IO t+type MToHndlFunc t = t -> IO HsQMLObjectHandle++type MarshallerFor t = Marshaller t+ (MarshalMode t ICanGetFrom ()) (MarshalMode t ICanPassTo ())+ (MarshalMode t ICanReturnTo ())+ (MarshalMode t IIsObjType ()) (MarshalMode t IGetObjType ())++type MarshallerForMode t m = Marshaller t+ (m ICanGetFrom) (m ICanPassTo) (m ICanReturnTo)+ (m IIsObjType) (m IGetObjType)+ -- | The class 'Marshal' allows Haskell values to be marshalled to and from the -- QML environment. class Marshal t where- -- | The 'MarshalMode' associated type parameter specifies the type of- -- marshalling functionality offered by the instance.- type MarshalMode t- -- | Yields the 'Marshaller' for the type @t@.- marshaller :: Marshaller t (MarshalMode t)+ -- | The 'MarshalMode' associated type family specifies the marshalling+ -- capabilities offered by the instance. @c@ indicates the capability being+ -- queried. @d@ is dummy parameter which allows certain instances to type+ -- check.+ type MarshalMode t c d+ -- | Yields the 'Marshaller' for the type @t@.+ marshaller :: MarshallerFor t --- | Base class containing core functionality for all 'MarshalMode's.-class MarshalBase m where- mTypeName_ :: forall t. Marshaller t m -> MTypeNameFunc t+-- | 'MarshalMode' for non-object types with bidirectional marshalling.+type family ModeBidi c+type instance ModeBidi ICanGetFrom = Yes+type instance ModeBidi ICanPassTo = Yes+type instance ModeBidi ICanReturnTo = Yes+type instance ModeBidi IIsObjType = No+type instance ModeBidi IGetObjType = No -mTypeName ::- forall t. (Marshal t, MarshalBase (MarshalMode t)) => MTypeNameFunc t-mTypeName = mTypeName_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for non-object types with from-only marshalling.+type family ModeFrom c+type instance ModeFrom ICanGetFrom = Yes+type instance ModeFrom ICanPassTo = No+type instance ModeFrom ICanReturnTo = No+type instance ModeFrom IIsObjType = No+type instance ModeFrom IGetObjType = No --- | Class for 'MarshalMode's which support marshalling QML-to-Haskell.-class (MarshalBase m) => MarshalToHs m where- mValToHs_ :: forall t. Marshaller t m -> MValToHsFunc t+-- | 'MarshalMode' for non-object types with to-only marshalling.+type family ModeTo c+type instance ModeTo ICanGetFrom = No+type instance ModeTo ICanPassTo = Yes+type instance ModeTo ICanReturnTo = Yes+type instance ModeTo IIsObjType = No+type instance ModeTo IGetObjType = No -mValToHs ::- forall t. (Marshal t, MarshalToHs (MarshalMode t)) => MValToHsFunc t-mValToHs = mValToHs_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for void in method returns.+type family ModeRetVoid c+type instance ModeRetVoid ICanGetFrom = No+type instance ModeRetVoid ICanPassTo = No+type instance ModeRetVoid ICanReturnTo = Yes+type instance ModeRetVoid IIsObjType = No+type instance ModeRetVoid IGetObjType = No --- | Class for 'MarshalMode's which support marshalling Haskell-to-QML.-class (MarshalBase m) => MarshalToValRaw m where- mHsToVal_ :: forall t. Marshaller t m -> MHsToValFunc t- mHsToAlloc_ :: forall t. Marshaller t m -> MHsToAllocFunc t+-- | 'MarshalMode' for object types with bidirectional marshalling.+type family ModeObjBidi a c+type instance ModeObjBidi a ICanGetFrom = Yes+type instance ModeObjBidi a ICanPassTo = Yes+type instance ModeObjBidi a ICanReturnTo = Yes+type instance ModeObjBidi a IIsObjType = Yes+type instance ModeObjBidi a IGetObjType = a -mHsToVal ::- forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToValFunc t-mHsToVal = mHsToVal_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for object types with from-only marshalling.+type family ModeObjFrom a c+type instance ModeObjFrom a ICanGetFrom = Yes+type instance ModeObjFrom a ICanPassTo = No+type instance ModeObjFrom a ICanReturnTo = No+type instance ModeObjFrom a IIsObjType = Yes+type instance ModeObjFrom a IGetObjType = a -mHsToAlloc ::- forall t. (Marshal t, MarshalToValRaw (MarshalMode t)) => MHsToAllocFunc t-mHsToAlloc = mHsToAlloc_ (marshaller :: Marshaller t (MarshalMode t))+-- | 'MarshalMode' for object types with to-only marshalling.+type family ModeObjTo a c+type instance ModeObjTo a ICanGetFrom = No+type instance ModeObjTo a ICanPassTo = Yes+type instance ModeObjTo a ICanReturnTo = Yes+type instance ModeObjTo a IIsObjType = Yes+type instance ModeObjTo a IGetObjType = a --- | Class for 'MarshalMode's which support marshalling Haskell-to-QML,--- excluding the return of void from methods.-class (MarshalToValRaw m) => MarshalToVal m where+-- | Type value indicating a capability is supported.+data Yes +-- | Type value indicating a capability is not supported.+data No++-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- received from QML.+type CanGetFrom t = MarshalMode t ICanGetFrom ()++-- | Type index into 'MarshalMode' for querying if the mode supports receiving+-- values from QML.+data ICanGetFrom++-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- passed to QML.+type CanPassTo t = MarshalMode t ICanPassTo ()++-- | Type index into 'MarshalMode' for querying if the mode supports passing+-- values to QML.+data ICanPassTo++-- | Type function equal to 'Yes' if the marshallable type @t@ supports being+-- returned to QML.+type CanReturnTo t = MarshalMode t ICanReturnTo ()++-- | Type index into 'MarshalMode' for querying if the mode supports returning+-- values to QML.+data ICanReturnTo++-- | Type function equal to 'Yes' if the marshallable type @t@ is an object.+type IsObjType t = MarshalMode t IIsObjType ()++-- | Type index into 'MarshalMode' for querying if the mode supports an object+-- type.+data IIsObjType++-- | Type function which returns the type encapsulated by the object handles+-- used by the marshallable type @t@.+type GetObjType t = MarshalMode t IGetObjType ()++-- | Type index into 'MarshalMode' for querying the type encapsulated by the+-- mode's object handles.+data IGetObjType+ -- | Encapsulates the functionality to needed to implement an instance of -- 'Marshal' so that such instances can be defined without access to -- implementation details.-data family Marshaller t m+data Marshaller t u v w x y = Marshaller {+ mTypeCVal_ :: !(MTypeCValFunc t),+ mFromCVal_ :: !(MFromCValFunc t),+ mToCVal_ :: !(MToCValFunc t),+ mWithCVal_ :: !(MWithCValFunc t),+ mFromJVal_ :: !(MFromJValFunc t),+ mWithJVal_ :: !(MWithJValFunc t),+ mFromHndl_ :: !(MFromHndlFunc t),+ mToHndl_ :: !(MToHndlFunc t)+} --- | 'MarshalMode' for built-in data types.-data ValBidi+mTypeCVal :: forall t. (Marshal t) => MTypeCValFunc t+mTypeCVal = mTypeCVal_ (marshaller :: MarshallerFor t) -data instance Marshaller t ValBidi = MValBidi {- mValBidi_typeName :: !(MTypeNameFunc t),- mValBidi_valToHs :: !(MValToHsFunc t),- mValBidi_hsToVal :: !(MHsToValFunc t),- mValBidi_hsToAlloc :: !(MHsToAllocFunc t)}+mFromCVal :: forall t. (Marshal t) => MFromCValFunc t+mFromCVal = mFromCVal_ (marshaller :: MarshallerFor t) -instance MarshalBase ValBidi where- mTypeName_ = mValBidi_typeName+mToCVal :: forall t. (Marshal t) => MToCValFunc t+mToCVal = mToCVal_ (marshaller :: MarshallerFor t) -instance MarshalToHs ValBidi where- mValToHs_ = mValBidi_valToHs+mWithCVal :: forall t. (Marshal t) => MWithCValFunc t+mWithCVal = mWithCVal_ (marshaller :: MarshallerFor t) -instance MarshalToValRaw ValBidi where- mHsToVal_ = mValBidi_hsToVal- mHsToAlloc_ = mValBidi_hsToAlloc+mFromJVal :: forall t. (Marshal t) => MFromJValFunc t+mFromJVal = mFromJVal_ (marshaller :: MarshallerFor t) -instance MarshalToVal ValBidi where+mWithJVal :: forall t. (Marshal t) => MWithJValFunc t+mWithJVal = mWithJVal_ (marshaller :: MarshallerFor t) --- | 'MarshalMode' for void in method returns.-data ValFnRetVoid+mFromHndl :: forall t. (Marshal t) => MFromHndlFunc t+mFromHndl = mFromHndl_ (marshaller :: MarshallerFor t) -data instance Marshaller t ValFnRetVoid = MValFnRetVoid {- mValFnRetVoid_typeName :: !(MTypeNameFunc t),- mValFnRetVoid_hsToVal :: !(MHsToValFunc t),- mValFnRetVoid_hsToAlloc :: !(MHsToAllocFunc t)}+mToHndl :: forall t. (Marshal t) => MToHndlFunc t+mToHndl = mToHndl_ (marshaller :: MarshallerFor t) -instance MarshalBase ValFnRetVoid where- mTypeName_ = mValFnRetVoid_typeName+unimplFromCVal :: MFromCValFunc t+unimplFromCVal _ = error "Type does not support mFromCVal." -instance MarshalToValRaw ValFnRetVoid where- mHsToVal_ = mValFnRetVoid_hsToVal- mHsToAlloc_ = mValFnRetVoid_hsToAlloc+unimplToCVal :: MToCValFunc t+unimplToCVal _ _ = error "Type does not support mToCVal." +unimplWithCVal :: MWithCValFunc t+unimplWithCVal _ _ = error "Type does not support mWithCVal."++unimplFromJVal :: MFromJValFunc t+unimplFromJVal _ = error "Type does not support mFromJVal."++unimplWithJVal :: MWithJValFunc t+unimplWithJVal _ _ = error "Type does not support mWithJVal."++unimplFromHndl :: MFromHndlFunc t+unimplFromHndl _ = error "Type does not support mFromHndl."++unimplToHndl :: MToHndlFunc t+unimplToHndl _ = error "Type does not support mToHndl."++jvalFromCVal :: (Marshal t) => MFromCValFunc t+jvalFromCVal = mFromJVal Strong . HsQMLJValHandle . castPtr++jvalToCVal :: (Marshal t) => MToCValFunc t+jvalToCVal val ptr = mWithJVal val $ \jval ->+ hsqmlSetJval (HsQMLJValHandle $ castPtr ptr) jval++jvalWithCVal :: (Marshal t) => MWithCValFunc t+jvalWithCVal val f = mWithJVal val $ \(HsQMLJValHandle ptr) ->+ f $ castPtr ptr+ instance Marshal () where- type MarshalMode () = ValFnRetVoid- marshaller = MValFnRetVoid {- mValFnRetVoid_typeName = Tagged $ TypeName "",- mValFnRetVoid_hsToVal = \_ _ -> return (),- mValFnRetVoid_hsToAlloc = \_ f -> f nullPtr}+ type MarshalMode () c d = ModeRetVoid c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyVoid,+ mFromCVal_ = unimplFromCVal,+ mToCVal_ = \_ _ -> return (),+ mWithCVal_ = unimplWithCVal,+ mFromJVal_ = unimplFromJVal,+ mWithJVal_ = unimplWithJVal,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}
src/Graphics/QML/Internal/MetaObj.hs view
@@ -1,11 +1,9 @@ module Graphics.QML.Internal.MetaObj where -import Graphics.QML.Internal.BindObj-import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Types import Control.Monad-import Control.Monad.Trans.State+import Control.Monad.Trans.State (State, execState, get, put) import Data.Bits import Data.Map (Map) import qualified Data.Map as Map@@ -28,14 +26,17 @@ crlEmpty :: CRList a crlEmpty = CRList 0 [] +crlSingle :: a -> CRList a+crlSingle x = CRList 1 [x]+ crlAppend1 :: CRList a -> a -> CRList a crlAppend1 (CRList n xs) x = CRList (n+1) (x:xs) crlAppend :: CRList a -> [a] -> CRList a crlAppend (CRList n xs) ys = CRList n' xs' where (xs', n') = rev ys xs n- rev [] vs n = (vs, n)- rev (u:us) vs n = rev us (u:vs) (n+1)+ rev [] vs m = (vs, m)+ rev (u:us) vs m = rev us (u:vs) (m+1) crlToNewArray :: (Storable b) => (a -> IO b) -> CRList a -> IO (Ptr b) crlToNewArray f (CRList len lst) = do@@ -49,16 +50,40 @@ pokeElemOff p n' x' pokeRev p xs n' +crlToList :: CRList a -> [a]+crlToList (CRList _ lst) = reverse lst+ -- -- Meta Object Compiler -- +data MemberKind+ = MethodMember+ | ConstPropertyMember+ | PropertyMember+ | SignalMember+ deriving Eq++-- | Represents a named member of the QML class which wraps type @tt@.+data Member tt = Member {+ memberKind :: MemberKind,+ memberName :: String,+ memberType :: TypeId,+ memberParams :: [(String, TypeId)],+ memberFun :: UniformFunc,+ memberFunAux :: Maybe UniformFunc,+ memberKey :: Maybe MemberKey+}+ data MOCState = MOCState { mData :: CRList CUInt, mDataMethodsIdx :: Maybe Int, mDataPropsIdx :: Maybe Int,- mStrData :: CRList CChar,- mStrDataMap :: Map String CUInt,+ mStrChar :: CRList CChar,+ mStrInfo :: CRList CUInt,+ mStrMap :: Map String CUInt,+ mParamMap :: Map [TypeId] CUInt,+ mSigMap :: Map MemberKey CUInt, mFuncMethods :: CRList (Maybe UniformFunc), mFuncProperties :: CRList (Maybe UniformFunc), mMethodCount :: Int,@@ -69,8 +94,8 @@ -- | Generate MOC meta-data from a class name and member list. compileClass :: String -> [Member tt] -> MOCState compileClass name ms = - let enc = flip execState newMOCState $ do- writeInt 5 -- Revision+ let enc = flip execState (newMOCState enc) $ do+ writeInt 7 -- Revision writeString name -- Class name writeInt 0 >> writeInt 0 -- Class info writeIntegral $@@ -85,20 +110,26 @@ writeInt 0 >> writeInt 0 -- Constructors writeInt 0 -- Flags writeIntegral $ mSignalCount enc -- Signals- mapM_ writeMethod $ filterMembers SignalMember ms- mapM_ writeMethod $ filterMembers MethodMember ms- mapM_ writeProperty $ filterMembers PropertyMember ms+ let mms = filterMembers SignalMember ms +++ filterMembers MethodMember ms+ mapM_ writeMethodParams mms+ mapM_ writeMethod mms+ let pms = filterMembers ConstPropertyMember ms +++ filterMembers PropertyMember ms+ mapM_ writeProperty pms+ mapM_ writePropertySig pms writeInt 0 in enc filterMembers :: MemberKind -> [Member tt] -> [Member tt]-filterMembers k ms =- filter (\m -> k == memberKind m) ms--newMOCState :: MOCState-newMOCState =- MOCState crlEmpty Nothing Nothing crlEmpty Map.empty crlEmpty crlEmpty 0 0 0+filterMembers k = filter (\m -> k == memberKind m) +newMOCState :: MOCState -> MOCState+newMOCState enc = MOCState+ crlEmpty Nothing Nothing crlEmpty (crlSingle strCount) Map.empty+ Map.empty Map.empty crlEmpty crlEmpty 0 0 0+ where strCount = fromIntegral $ Map.size $ mStrMap enc+ writeInt :: CUInt -> State MOCState () writeInt int = do state <- get@@ -112,35 +143,58 @@ writeString :: String -> State MOCState () writeString str = do state <- get- let msd = mStrData state- msdMap = mStrDataMap state- case (Map.lookup str msdMap) of+ let msChr = mStrChar state+ msInf = mStrInfo state+ msMap = mStrMap state+ case Map.lookup str msMap of Just idx -> writeInt idx Nothing -> do- let idx = crlLen msd- msd' = msd `crlAppend` (map castCharToCChar str) `crlAppend1` 0- msdMap' = Map.insert str (fromIntegral idx) msdMap+ let idx = crlLen msInf - 1+ msChr' = msChr `crlAppend` map castCharToCChar str `crlAppend1` 0+ msInf' = msInf `crlAppend1` fromIntegral (crlLen msChr')+ msMap' = Map.insert str (fromIntegral idx) msMap put $ state {- mStrData = msd',- mStrDataMap = msdMap'}+ mStrChar = msChr',+ mStrInfo = msInf',+ mStrMap = msMap'} writeIntegral idx +writeMethodParams :: Member tt -> State MOCState ()+writeMethodParams m = do+ state <- get+ let types = memberTypes m+ datal = mData state+ mpMap = mParamMap state+ case Map.lookup types mpMap of+ Just _ -> return ()+ Nothing -> do+ let idx = crlLen datal+ mpMap' = Map.insert types (fromIntegral idx) mpMap+ put $ state {+ mParamMap = mpMap'}+ mapM_ (writeInt . typeId) types+ mapM_ (writeString . fst) $ memberParams m+ writeMethod :: Member tt -> State MOCState () writeMethod m = do idx <- get >>= return . crlLen . mData- writeString $ methodSignature m- writeString $ methodParameters m- writeString $ typeName $ memberType m+ paramMap <- get >>= return . mParamMap+ writeString $ memberName m+ writeIntegral $ length $ memberParams m+ writeInt $ fromMaybe 0 $ flip Map.lookup paramMap $ memberTypes m writeString "" let (mc,sc,flags) = case memberKind m of SignalMember -> (0,1,mfMethodSignal)- _ -> (1,0,0)+ _ -> (1,0,mfMethodMethod) writeInt (mfAccessPublic .|. mfMethodScriptable .|. flags) state <- get put $ state { mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx),- mMethodCount = mc + (mMethodCount state),- mSignalCount = sc + (mSignalCount state),+ mMethodCount = mc + mMethodCount state,+ mSignalCount = sc + mSignalCount state,+ mSigMap = maybe (mSigMap state) (\k ->+ Map.insert k (fromIntegral $ mSignalCount state) (mSigMap state)) $+ memberKey m, mFuncMethods = mFuncMethods state `crlAppend1` (Just $ memberFun m)} return () @@ -148,32 +202,31 @@ writeProperty p = do idx <- get >>= return . crlLen . mData writeString $ memberName p- writeString $ typeName $ memberType p+ writeInt $ typeId $ memberType p writeInt (pfReadable .|. pfScriptable .|.- if (isJust $ memberFunAux p) then pfWritable else 0)+ (if ConstPropertyMember == memberKind p then pfConstant else 0) .|.+ (if isJust (memberFunAux p) then pfWritable else 0) .|.+ (if isJust (memberKey p) then pfNotify else 0)) state <- get put $ state { mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx),- mPropertyCount = 1 + (mPropertyCount state),+ mPropertyCount = 1 + mPropertyCount state, mFuncProperties = mFuncProperties state `crlAppend1` (Just $ memberFun p) `crlAppend1` memberFunAux p } return () -foldr0 :: (a -> a -> a) -> a -> [a] -> a-foldr0 _ x [] = x-foldr0 f _ xs = foldr1 f xs+writePropertySig :: Member tt -> State MOCState ()+writePropertySig p = do+ state <- get+ writeInt $ fromMaybe 0 $ maybe Nothing (flip Map.lookup $ mSigMap state) $+ memberKey p -methodSignature :: Member tt -> String-methodSignature method =- let paramTypes = memberParams method- in (showString (memberName method) . showChar '(' .- foldr0 (\l r -> l . showChar ',' . r) id- (map (showString . typeName) paramTypes) . showChar ')') ""+memberTypes :: Member tt -> [TypeId]+memberTypes m = memberType m : (map snd $ memberParams m) -methodParameters :: Member tt -> String-methodParameters method =- replicate (flip (-) 1 $ length $ memberParams method) ','+typeId :: TypeId -> CUInt+typeId (TypeId tyid) = fromIntegral tyid -- -- Constants
src/Graphics/QML/Internal/Objects.hs view
@@ -1,122 +1,78 @@ {-# LANGUAGE ScopedTypeVariables,- TypeFamilies,- FlexibleContexts,- FlexibleInstances,- Rank2Types+ TypeFamilies #-} module Graphics.QML.Internal.Objects where import Graphics.QML.Internal.BindObj import Graphics.QML.Internal.Marshal+import Graphics.QML.Internal.Types +import Control.Monad.Trans.Maybe+import Data.Tagged import Data.Typeable-import Data.Bits-import Data.Char--data MemberKind- = MethodMember- | PropertyMember- | SignalMember- deriving (Bounded, Enum, Eq)---- | Represents a named member of the QML class which wraps type @tt@.-data Member tt = Member {- memberKind :: MemberKind,- memberName :: String,- memberType :: TypeName,- memberParams :: [TypeName],- memberFun :: UniformFunc,- memberFunAux :: Maybe UniformFunc,- memberKey :: Maybe TypeRep-}---- | Represents the API of the QML class which wraps the type @tt@.-newtype ClassDef tt = ClassDef {- classMembers :: [Member tt]-}---- | The class 'Object' allows Haskell types to expose an object-oriented--- interface to QML. -class (Typeable tt) => Object tt where- classDef :: ClassDef tt--type MObjToHsFunc t = HsQMLObjectHandle -> IO t-type MHsToObjFunc t = t -> IO HsQMLObjectHandle---- | Type function yielding the object type specified by a given 'MarshalMode'.-type family ModeObj m---- | Type function yielding the object type speficied by a given marshallable--- type @tt@.-type ThisObj tt = ModeObj (MarshalMode tt)---- | Class for 'MarshalMode's which support marshalling QML-to-Haskell--- in contexts specific to objects.-class (MarshalBase m) => MarshalFromObj m where- mObjToHs_ :: forall t. Marshaller t m -> MObjToHsFunc t--mObjToHs ::- forall t. (Marshal t, MarshalFromObj (MarshalMode t)) => MObjToHsFunc t-mObjToHs = mObjToHs_ (marshaller :: Marshaller t (MarshalMode t))---- | Class for 'MarshalMode's which support marshalling Haskell-to-QML--- in contexts specific to objects.-class (MarshalBase m) => MarshalToObj m where- mHsToObj_ :: forall t. Marshaller t m -> MHsToObjFunc t--mHsToObj ::- forall t. (Marshal t, MarshalToObj (MarshalMode t)) => MHsToObjFunc t-mHsToObj = mHsToObj_ (marshaller :: Marshaller t (MarshalMode t))---- | 'MarshalMode' for object types.-data ValObjBidi a-type instance ModeObj (ValObjBidi a) = a--data instance Marshaller t (ValObjBidi a) = MValObjBidi {- mValObjBidi_typeName :: !(MTypeNameFunc t),- mValObjBidi_valToHs :: !(MValToHsFunc t),- mValObjBidi_hsToVal :: !(MHsToValFunc t),- mValObjBidi_hsToAlloc :: !(MHsToAllocFunc t),- mValObjBidi_objToHs :: !(MObjToHsFunc t),- mValObjBidi_hsToObj :: !(MHsToObjFunc t)}--instance MarshalBase (ValObjBidi a) where- mTypeName_ = mValObjBidi_typeName--instance MarshalToHs (ValObjBidi a) where- mValToHs_ = mValObjBidi_valToHs--instance MarshalToValRaw (ValObjBidi a) where- mHsToVal_ = mValObjBidi_hsToVal- mHsToAlloc_ = mValObjBidi_hsToAlloc--instance MarshalToVal (ValObjBidi a) where--instance MarshalToObj (ValObjBidi a) where- mHsToObj_ = mValObjBidi_hsToObj--instance MarshalFromObj (ValObjBidi a) where- mObjToHs_ = mValObjBidi_objToHs---- | 'MarshalMode' for object types, operating only in the QML-to-Haskell--- direction.-data ValObjToOnly a+import Foreign.ForeignPtr -type instance ModeObj (ValObjToOnly a) = a+-- | Represents an instance of the QML class which wraps the type @tt@.+newtype ObjRef tt = ObjRef HsQMLObjectHandle -data instance Marshaller t (ValObjToOnly a) = MValObjToOnly {- mValObjToOnly_typeName :: !(MTypeNameFunc t),- mValObjToOnly_valToHs :: !(MValToHsFunc t),- mValObjToOnly_objToHs :: !(MObjToHsFunc t)}+instance (Typeable tt) => Marshal (ObjRef tt) where+ type MarshalMode (ObjRef tt) c d = ModeObjBidi tt c+ marshaller = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged AnyObjRef TypeId),+ mFromCVal_ = \ptr -> do+ anyObj <- mFromCVal ptr+ MaybeT $ fromAnyObjRefIO anyObj,+ mToCVal_ = \(ObjRef hndl) ptr ->+ mToCVal (AnyObjRef hndl) ptr,+ mWithCVal_ = \(ObjRef hndl) f ->+ mWithCVal (AnyObjRef hndl) f,+ mFromJVal_ = \_ ptr -> do+ anyObj <- mFromJVal Weak ptr+ MaybeT $ fromAnyObjRefIO anyObj,+ mWithJVal_ = \(ObjRef hndl) f ->+ mWithJVal (AnyObjRef hndl) f,+ mFromHndl_ =+ return . ObjRef,+ mToHndl_ = \(ObjRef hndl) ->+ return hndl} -instance MarshalBase (ValObjToOnly a) where- mTypeName_ = mValObjToOnly_typeName+fromObjRefIO :: ObjRef tt -> IO tt+fromObjRefIO (ObjRef hndl) = hsqmlObjectGetHsValue hndl -instance MarshalToHs (ValObjToOnly a) where- mValToHs_ = mValObjToOnly_valToHs+-- | Represents an instance of a QML class which wraps an arbitrary Haskell+-- type. Unlike 'ObjRef', an 'AnyObjRef' only carries the type of its Haskell+-- value dynamically and does not encode it into the static type.+newtype AnyObjRef = AnyObjRef HsQMLObjectHandle -instance MarshalFromObj (ValObjToOnly a) where- mObjToHs_ = mValObjToOnly_objToHs+instance Marshal AnyObjRef where+ type MarshalMode AnyObjRef c d = ModeObjBidi No c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \_ ptr -> MaybeT $ do+ hndl <- hsqmlGetObjectFromJval ptr+ return $ if isNullObjectHandle hndl+ then Nothing else Just $ AnyObjRef hndl,+ mWithJVal_ = \(AnyObjRef hndl@(HsQMLObjectHandle ptr)) f -> do+ jval <- hsqmlObjectGetJval hndl+ ret <- f jval+ touchForeignPtr ptr+ return ret,+ mFromHndl_ =+ return . AnyObjRef,+ mToHndl_ = \(AnyObjRef hndl) ->+ return hndl} +fromAnyObjRefIO :: forall tt. (Typeable tt) =>+ AnyObjRef -> IO (Maybe (ObjRef tt))+fromAnyObjRefIO (AnyObjRef hndl) = do+ info <- hsqmlObjectGetHsTyperep hndl+ let srcRep = typeOf (undefined :: tt)+ dstRep = cinfoObjType info+ return $ if srcRep == dstRep+ then Just $ ObjRef hndl+ else Nothing
+ src/Graphics/QML/Internal/Types.hs view
@@ -0,0 +1,22 @@+module Graphics.QML.Internal.Types where++import Data.Map (Map)+import Data.Typeable+import Data.Unique+import Foreign.Ptr++newtype TypeId = TypeId Int deriving (Eq, Ord)++type UniformFunc = Ptr () -> Ptr (Ptr ()) -> IO ()++data MemberKey+ = TypeKey TypeRep+ | DataKey Unique+ deriving (Eq, Ord)++data ClassInfo = ClassInfo {+ cinfoObjType :: TypeRep,+ cinfoSignals :: Map MemberKey Int+}++data Strength = Strong | Weak
src/Graphics/QML/Marshal.hs view
@@ -1,160 +1,344 @@ {-# LANGUAGE ScopedTypeVariables, TypeFamilies,- TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- | Type classs and instances for marshalling values between Haskell and QML. module Graphics.QML.Marshal (+ -- * Marshalling Type-class Marshal ( type MarshalMode, marshaller),- MarshalToHs,- MarshalToValRaw,- MarshalToVal,- MarshalFromObj,- MarshalToObj,- ValBidi,- ValFnRetVoid,- ValObjBidi,- ValObjToOnly,- ThisObj,- Marshaller + ModeBidi,+ ModeFrom,+ ModeTo,+ ModeRetVoid,+ ModeObjBidi,+ ModeObjFrom,+ ModeObjTo,+ Yes,+ CanGetFrom,+ ICanGetFrom,+ CanPassTo,+ ICanPassTo,+ CanReturnTo,+ ICanReturnTo,+ IsObjType,+ IIsObjType,+ GetObjType,+ IGetObjType,+ Marshaller,++ -- * Data Types+ Ignored (+ Ignored),++ -- * Custom Marshallers+ bidiMarshallerIO,+ bidiMarshaller,+ fromMarshallerIO,+ fromMarshaller,+ toMarshallerIO,+ toMarshaller ) where import Graphics.QML.Internal.BindPrim import Graphics.QML.Internal.Marshal-import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Types -import Data.Maybe+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 as T-import qualified Data.Text.Foreign as T+import qualified Data.Text.Encoding as TE import Foreign.C.Types-import Foreign.C.String import Foreign.Marshal.Alloc+import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr import Foreign.Storable-import Network.URI (- URI (URI), URIAuth (URIAuth),- parseURIReference, unEscapeString,- uriToString, escapeURIString, nullURI,- isUnescapedInURI) --+-- Boolean built-in type+--++instance Marshal Bool where+ type MarshalMode Bool c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalBool hsqmlGetJvalBool ptr,+ mWithJVal_ = \bool f ->+ withJVal hsqmlInitJvalBool bool f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}++-- -- Int32/int built-in type -- instance Marshal Int32 where- type MarshalMode Int32 = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "int",- mValBidi_valToHs = \ptr ->- errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,- mValBidi_hsToVal = \int ptr ->- poke (castPtr ptr :: Ptr CInt) (fromIntegral int),- mValBidi_hsToAlloc = \int f ->- alloca $ \(ptr :: Ptr CInt) ->- mHsToVal int (castPtr ptr) >> f (castPtr ptr)}+ type MarshalMode Int32 c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyInt,+ mFromCVal_ = \ptr ->+ errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,+ mToCVal_ = \int ptr ->+ poke (castPtr ptr :: Ptr CInt) (fromIntegral int),+ mWithCVal_ = \int f ->+ alloca $ \(ptr :: Ptr CInt) ->+ mToCVal int (castPtr ptr) >> f (castPtr ptr),+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalNumber (+ fmap fromIntegral . hsqmlGetJvalInt) ptr,+ mWithJVal_ = \int f ->+ withJVal hsqmlInitJvalInt (fromIntegral int) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} instance Marshal Int where- type MarshalMode Int = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "int",- mValBidi_valToHs = fmap (fromIntegral :: Int32 -> Int) . mValToHs,- mValBidi_hsToVal = \int ptr -> mHsToVal (fromIntegral int :: Int32) ptr,- mValBidi_hsToAlloc = \int f -> mHsToAlloc (fromIntegral int :: Int32) f}+ type MarshalMode Int c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyInt,+ mFromCVal_ = fmap (fromIntegral :: Int32 -> Int) . mFromCVal,+ mToCVal_ = \int ptr -> mToCVal (fromIntegral int :: Int32) ptr,+ mWithCVal_ = \int f -> mWithCVal (fromIntegral int :: Int32) f,+ mFromJVal_ = \s -> fmap (fromIntegral :: Int32 -> Int) . mFromJVal s,+ mWithJVal_ = \int f -> mWithJVal (fromIntegral int :: Int32) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -- -- Double/double built-in type -- instance Marshal Double where- type MarshalMode Double = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "double",- mValBidi_valToHs = \ptr ->- errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,- mValBidi_hsToVal = \num ptr ->- poke (castPtr ptr :: Ptr CDouble) (realToFrac num),- mValBidi_hsToAlloc = \num f ->- alloca $ \(ptr :: Ptr CDouble) ->- mHsToVal num (castPtr ptr) >> f (castPtr ptr)}+ type MarshalMode Double c d = ModeBidi c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyDouble,+ mFromCVal_ = \ptr ->+ errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,+ mToCVal_ = \num ptr ->+ poke (castPtr ptr :: Ptr CDouble) (realToFrac num),+ mWithCVal_ = \num f ->+ alloca $ \(ptr :: Ptr CDouble) ->+ mToCVal num (castPtr ptr) >> f (castPtr ptr),+ mFromJVal_ = \s ptr ->+ MaybeT $ fromJVal s hsqmlIsJvalNumber (+ fmap realToFrac . hsqmlGetJvalDouble) ptr,+ mWithJVal_ = \num f ->+ withJVal hsqmlInitJvalDouble (realToFrac num) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -- -- Text/QString built-in type -- + instance Marshal Text where- type MarshalMode Text = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QString",- mValBidi_valToHs = \ptr -> errIO $ do- pair <- alloca (\bufPtr -> do- len <- hsqmlUnmarshalString (HsQMLStringHandle $ castPtr ptr) bufPtr- buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- uncurry T.fromPtr pair,- mValBidi_hsToVal = \txt ptr -> do- array <- hsqmlMarshalString- (T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)- T.unsafeCopyToPtr txt (castPtr array),- mValBidi_hsToAlloc = \txt f ->- allocaBytes hsqmlStringSize $ \ptr -> do- hsqmlInitString $ HsQMLStringHandle ptr- mHsToVal txt (castPtr ptr)- ret <- f (castPtr ptr)- hsqmlDeinitString $ HsQMLStringHandle ptr- return ret}+ 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+ buf <- peek bufPtr+ return (buf, len))+ let (buf, len) = pair+ bs <- BS.packCStringLen (castPtr buf, len * 2)+ return $ TE.decodeUtf16LE bs,+ mToCVal_ = \txt ptr -> do+ 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+ f $ castPtr ptr,+ mFromJVal_ = \s jval ->+ MaybeT $ withStrHndl $ \sHndl -> runMaybeT $ do+ MaybeT $ fromJVal s hsqmlIsJvalString (+ flip hsqmlGetJvalString sHndl) jval+ let (HsQMLStringHandle ptr) = sHndl+ mFromCVal $ castPtr ptr,+ mWithJVal_ = \txt f ->+ mWithCVal txt $ \ptr -> withJVal hsqmlInitJvalString (+ HsQMLStringHandle $ castPtr ptr) f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} ----- String/QString built-in type+-- Maybe -- -instance Marshal String where- type MarshalMode String = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QString",- mValBidi_valToHs = fmap T.unpack . mValToHs,- mValBidi_hsToVal = \txt ptr -> mHsToVal (T.pack txt) ptr,- mValBidi_hsToAlloc = \txt f -> mHsToAlloc (T.pack txt) f}+instance (Marshal a) => Marshal (Maybe a) where+ type MarshalMode (Maybe a) ICanGetFrom d = MarshalMode a ICanGetFrom d+ type MarshalMode (Maybe a) ICanPassTo d = MarshalMode a ICanPassTo d+ type MarshalMode (Maybe a) ICanReturnTo d = MarshalMode a ICanReturnTo d+ type MarshalMode (Maybe a) IIsObjType d = No+ type MarshalMode (Maybe a) IGetObjType d = No+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \_ jval -> errIO $ runMaybeT $ mFromJVal Weak jval,+ mWithJVal_ = \val f ->+ case val of+ Just val' -> mWithJVal val' f+ Nothing -> withJVal hsqmlInitJvalNull False f,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} ----- URI/QUrl built-in type+-- List -- -mapURIStrings :: (String -> String) -> URI -> URI-mapURIStrings f (URI scheme auth path query frag) =- URI (f scheme) (mapAuth auth) (f path) (f query) (f frag)- where mapAuth (Just (URIAuth user name port)) =- Just $ URIAuth (f user) (f name) (f port)- mapAuth Nothing = Nothing+instance (Marshal a) => Marshal [a] where+ type MarshalMode [a] ICanGetFrom d = MarshalMode a ICanGetFrom d+ type MarshalMode [a] ICanPassTo d = MarshalMode a ICanPassTo d+ type MarshalMode [a] ICanReturnTo d = MarshalMode a ICanReturnTo d+ type MarshalMode [a] IIsObjType d = No+ type MarshalMode [a] IGetObjType d = No+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = jvalToCVal,+ mWithCVal_ = jvalWithCVal,+ mFromJVal_ = \s jval -> MaybeT $ do+ len <- hsqmlGetJvalArrayLength jval+ withJVal hsqmlInitJvalNull True $ \tmp ->+ runMaybeT $ forM [0..len-1] $ \i -> do+ errIO $ hsqmlJvalArrayGet jval i tmp+ mFromJVal s tmp,+ mWithJVal_ = \vs f ->+ withJVal hsqmlInitJvalArray (length vs) $ \jval -> do+ forM_ (zip [0..] vs) $ uncurry $ \i val ->+ mWithJVal val $ \jval' ->+ hsqmlJvalArraySet jval i jval'+ f jval,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl} -instance Marshal URI where- type MarshalMode URI = ValBidi- marshaller = MValBidi {- mValBidi_typeName = Tagged $ TypeName "QUrl",- mValBidi_valToHs = \ptr -> errIO $ do- pair <- alloca (\bufPtr -> do- len <- hsqmlUnmarshalUrl (HsQMLUrlHandle $ castPtr ptr) bufPtr- buf <- peek bufPtr- return (castPtr buf, fromIntegral len))- str <- peekCStringLen pair- free $ fst pair- return $ mapURIStrings unEscapeString $- fromMaybe nullURI $ parseURIReference str,- mValBidi_hsToVal = \uri ptr ->- let str = uriToString id (mapURIStrings- (escapeURIString isUnescapedInURI) uri) ""- in withCStringLen str (\(buf, bufLen) ->- hsqmlMarshalUrl buf bufLen (HsQMLUrlHandle $ castPtr ptr)),- mValBidi_hsToAlloc = \uri f ->- allocaBytes hsqmlUrlSize $ \ptr -> do- hsqmlInitUrl $ HsQMLUrlHandle ptr- mHsToVal uri (castPtr ptr)- ret <- f (castPtr ptr)- hsqmlDeinitUrl $ HsQMLUrlHandle ptr- return ret}+--+-- Ignored+--++-- | Represents an argument whose value is ignored.++data Ignored = Ignored++instance Marshal Ignored where+ type MarshalMode Ignored c d = ModeFrom c+ marshaller = Marshaller {+ mTypeCVal_ = Tagged tyJSValue,+ mFromCVal_ = jvalFromCVal,+ mToCVal_ = unimplToCVal,+ mWithCVal_ = unimplWithCVal,+ mFromJVal_ = \_ _ -> MaybeT . return $ Just Ignored,+ mWithJVal_ = unimplWithJVal,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = unimplToHndl}++type BidiMarshaller a b = Marshaller b+ (MarshalMode a ICanGetFrom ())+ (MarshalMode a ICanPassTo ())+ (MarshalMode a ICanReturnTo ())+ (MarshalMode a IIsObjType ())+ (MarshalMode a IGetObjType ())++-- | Provides a bidirectional 'Marshaller' which allows you to define an+-- instance of 'Marshal' for your own type @b@ in terms of another marshallable+-- type @a@. Type @b@ should have a 'MarshalMode' of 'ModeObjBidi' or+-- 'ModeBidi' depending on whether @a@ was an object type or not.+bidiMarshallerIO ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>+ (a -> IO b) -> (b -> IO a) -> BidiMarshaller a b+bidiMarshallerIO fromFn toFn = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+ mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr,+ mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val,+ mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,+ mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr,+ mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,+ mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,+ mToHndl_ = \val -> mToHndl =<< toFn val}++-- | Variant of 'bidiMarshallerIO' where the conversion functions between types+-- @a@ and @b@ do not live in the IO monad.+bidiMarshaller ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>+ (a -> b) -> (b -> a) -> BidiMarshaller a b+bidiMarshaller fromFn toFn =+ bidiMarshallerIO (return . fromFn) (return . toFn)++type FromMarshaller a b = Marshaller b+ (MarshalMode a ICanGetFrom ())+ No+ No+ (MarshalMode a IIsObjType ())+ (MarshalMode a IGetObjType ())++-- | Provides a "from" 'Marshaller' which allows you to define an instance of+-- 'Marshal' for your own type @b@ in terms of another marshallable type @a@.+-- Type @b@ should have a 'MarshalMode' of 'ModeObjFrom' or 'ModeFrom'+-- depending on whether @a@ was an object type or not.+fromMarshallerIO ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes) =>+ (a -> IO b) -> FromMarshaller a b+fromMarshallerIO fromFn = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+ mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr,+ mToCVal_ = unimplToCVal,+ mWithCVal_ = unimplWithCVal,+ mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr,+ mWithJVal_ = unimplWithJVal,+ mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,+ mToHndl_ = unimplToHndl}++-- | Variant of 'fromMarshallerIO' where the conversion function between types+-- @a@ and @b@ does not live in the IO monad.+fromMarshaller ::+ forall a b. (Marshal a, CanGetFrom a ~ Yes) =>+ (a -> b) -> FromMarshaller a b+fromMarshaller fromFn = fromMarshallerIO (return . fromFn)++type ToMarshaller a b = Marshaller b+ No+ (MarshalMode a ICanPassTo ())+ (MarshalMode a ICanReturnTo ())+ (MarshalMode a IIsObjType ())+ (MarshalMode a IGetObjType ())++-- | Provides a "to" 'Marshaller' which allows you to define an instance of+-- 'Marshal' for your own type @b@ in terms of another marshallable type @a@.+-- Type @b@ should have a 'MarshalMode' of 'ModeObjTo' or 'ModeTo'+-- depending on whether @a@ was an object type or not.+toMarshallerIO ::+ forall a b. (Marshal a, CanPassTo a ~ Yes) =>+ (b -> IO a) -> ToMarshaller a b+toMarshallerIO toFn = Marshaller {+ mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),+ mFromCVal_ = unimplFromCVal,+ mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val,+ mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,+ mFromJVal_ = unimplFromJVal,+ mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,+ mFromHndl_ = unimplFromHndl,+ mToHndl_ = \val -> mToHndl =<< toFn val}++-- | Variant of 'toMarshallerIO' where the conversion function between types+-- @a@ and @b@ does not live in the IO monad.+toMarshaller ::+ forall a b. (Marshal a, CanPassTo a ~ Yes) =>+ (b -> a) -> ToMarshaller a b+toMarshaller toFn = toMarshallerIO (return . toFn)
+ 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
@@ -2,47 +2,57 @@ ScopedTypeVariables, TypeFamilies, FlexibleContexts,- FlexibleInstances+ FlexibleInstances,+ LiberalTypeSynonyms #-} -- | Facilities for defining new object types which can be marshalled between -- Haskell and QML. module Graphics.QML.Objects (+ -- * Object References+ ObjRef,+ newObject,+ newObjectDC,+ fromObjRef,++ -- * Dynamic Object References+ AnyObjRef,+ anyObjRef,+ fromAnyObjRef,+ -- * Class Definition- Object (- classDef),- ClassDef,+ Class,+ newClass,+ DefaultClass (+ classMembers), Member,- defClass, -- * Methods defMethod,+ defMethod', MethodSuffix, - -- * Properties- defPropertyRO,- defPropertyRW,- -- * Signals defSignal,+ defSignalNamedParams, fireSignal,- SignalKey (+ SignalKey,+ newSignalKey,+ SignalKeyClass ( type SignalParams), SignalSuffix, - -- * Object References- ObjRef,- newObject,- fromObjRef,-- -- * Dynamic Object References- AnyObjRef,- anyObjRef,- fromAnyObjRef,-- -- * Customer Marshallers- objSimpleMarshaller,- objBidiMarshaller+ -- * Properties+ defPropertyConst,+ defPropertyRO,+ defPropertySigRO,+ defPropertyRW,+ defPropertySigRW,+ defPropertyConst',+ defPropertyRO',+ defPropertySigRO',+ defPropertyRW',+ defPropertySigRW' ) where import Graphics.QML.Internal.BindCore@@ -51,18 +61,21 @@ import Graphics.QML.Internal.Marshal import Graphics.QML.Internal.MetaObj import Graphics.QML.Internal.Objects+import Graphics.QML.Internal.Types+import Graphics.QML.Objects.ParamNames import Control.Concurrent.MVar-import Control.Monad.Trans.Maybe import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Maybe+import Data.Proxy import Data.Tagged import Data.Typeable import Data.IORef+import Data.Unique import Foreign.Ptr import Foreign.Storable-import Foreign.Marshal.Alloc import Foreign.Marshal.Array import System.IO.Unsafe import Numeric@@ -71,71 +84,22 @@ -- ObjRef -- --- | Represents an instance of the QML class which wraps the type @tt@.-data ObjRef tt = ObjRef {- objHndl :: HsQMLObjectHandle-}--instance (Object tt) => Marshal (ObjRef tt) where- type MarshalMode (ObjRef tt) = ValObjBidi tt- marshaller = MValObjBidi {- mValObjBidi_typeName = Tagged $ TypeName "QObject*",- mValObjBidi_valToHs = \ptr -> do- any <- mValToHs ptr- MaybeT $ return $ fromAnyObjRef any,- mValObjBidi_hsToVal = \obj ptr ->- mHsToVal (AnyObjRef $ objHndl obj) ptr,- mValObjBidi_hsToAlloc = \obj f ->- mHsToAlloc (AnyObjRef $ objHndl obj) f,- mValObjBidi_objToHs = \hndl ->- return $ ObjRef hndl,- mValObjBidi_hsToObj = \obj ->- return $ objHndl obj}+-- | Creates a QML object given a 'Class' and a Haskell value of type @tt@.+newObject :: forall tt. Class tt -> tt -> IO (ObjRef tt)+newObject (Class cHndl) obj =+ fmap ObjRef $ hsqmlCreateObject obj cHndl --- | Creates an instance of a QML class given a value of the underlying Haskell --- type @tt@.-newObject :: forall tt. (Object tt) => tt -> IO (ObjRef tt)-newObject obj = do- cRec <- getClassRec (classDef :: ClassDef tt)- oHndl <- hsqmlCreateObject obj $ crecHndl cRec- return $ ObjRef oHndl+-- | Creates a QML object given a Haskell value of type @tt@ which has a+-- 'DefaultClass' instance.+newObjectDC :: forall tt. (DefaultClass tt) => tt -> IO (ObjRef tt)+newObjectDC obj = do+ clazz <- getDefaultClass :: IO (Class tt)+ newObject clazz obj -- | Returns the associated value of the underlying Haskell type @tt@ from an -- instance of the QML class which wraps it. fromObjRef :: ObjRef tt -> tt-fromObjRef =- unsafePerformIO . fromObjRefIO--fromObjRefIO :: ObjRef tt -> IO tt-fromObjRefIO =- hsqmlObjectGetHaskell . objHndl ---- | Represents an instance of a QML class which wraps an arbitrary Haskell--- type. Unlike 'ObjRef', an 'AnyObjRef' only carries the type of its Haskell--- value dynamically and does not encode it into the static type.-data AnyObjRef = AnyObjRef {- anyObjHndl :: HsQMLObjectHandle-}--instance Marshal AnyObjRef where- type MarshalMode AnyObjRef = ValObjBidi ()- marshaller = MValObjBidi {- mValObjBidi_typeName = Tagged $ TypeName "QObject*",- mValObjBidi_valToHs = \ptr -> MaybeT $ do- objPtr <- peek (castPtr ptr)- hndl <- hsqmlGetObjectHandle objPtr- return $ if isNullObjectHandle hndl- then Nothing else Just $ AnyObjRef hndl,- mValObjBidi_hsToVal = \obj ptr -> do- objPtr <- hsqmlObjectGetPointer $ anyObjHndl obj- poke (castPtr ptr) objPtr,- mValObjBidi_hsToAlloc = \obj f ->- alloca $ \(ptr :: Ptr (Ptr ())) ->- flip mHsToVal (castPtr ptr) obj >> f (castPtr ptr),- mValObjBidi_objToHs = \hndl ->- return $ AnyObjRef hndl,- mValObjBidi_hsToObj = \obj ->- return $ anyObjHndl obj}+fromObjRef = unsafeDupablePerformIO . fromObjRefIO -- | Upcasts an 'ObjRef' into an 'AnyObjRef'. anyObjRef :: ObjRef tt -> AnyObjRef@@ -143,70 +107,63 @@ -- | Attempts to downcast an 'AnyObjRef' into an 'ObjRef' with the specific -- underlying Haskell type @tt@.-fromAnyObjRef :: (Object tt) => AnyObjRef -> Maybe (ObjRef tt)-fromAnyObjRef = unsafePerformIO . fromAnyObjRefIO--fromAnyObjRefIO :: forall tt. (Object tt) => AnyObjRef -> IO (Maybe (ObjRef tt))-fromAnyObjRefIO (AnyObjRef hndl) = do- let srcRep = typeOf (undefined :: tt)- dstRep <- hsqmlObjectGetHsTyperep hndl- if srcRep == dstRep- then return $ Just $ ObjRef hndl- else return Nothing+fromAnyObjRef :: (Typeable tt) => AnyObjRef -> Maybe (ObjRef tt)+fromAnyObjRef = unsafeDupablePerformIO . fromAnyObjRefIO --- | Provides a QML-to-Haskell 'Marshaller' which allows you to define--- instances of 'Marshal' for custom 'Object' types. This allows a custom types--- to be passed into Haskell code as method parameters without having to--- manually deal with 'ObjRef's. ----- For example, an instance for 'MyObjectType' would be defined as follows:+-- Class ----- @--- instance Marshal MyObjectType where--- type MarshalMode MyObjectType = ValObjToOnly MyObjectType--- marshaller = objSimpleMarshaller--- @-objSimpleMarshaller ::- forall obj. (Object obj) => Marshaller obj (ValObjToOnly obj)-objSimpleMarshaller = MValObjToOnly {- mValObjToOnly_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),- mValObjToOnly_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,- mValObjToOnly_objToHs = hsqmlObjectGetHaskell} --- | Provides a bidirectional QML-to-Haskell and Haskell-to-QML 'Marshaller'--- which allows you to define instances of 'Marshal' for custom object types.--- This allows a custom type to be passed in and out of Haskell code via--- methods, properties, and signals, without having to manually deal with--- 'ObjRef's. Unlike the simple marshaller, this one must be given a function--- which specifies how to obtain an 'ObjRef' given a Haskell value.------ For example, an instance for 'MyObjectType' which simply creates a new--- object whenever one is required would be defined as follows:------ @--- instance Marshal MyObjectType where--- type MarshalMode MyObjectType = ValObjBidi MyObjectType--- marshaller = objBidiMarshaller newObject--- @-objBidiMarshaller ::- forall obj. (Object obj) =>- (obj -> IO (ObjRef obj)) -> Marshaller obj (ValObjBidi obj) -objBidiMarshaller newFn = MValObjBidi {- mValObjBidi_typeName = retag (mTypeName :: Tagged (ObjRef obj) TypeName),- mValObjBidi_valToHs = \ptr -> (errIO . fromObjRefIO) =<< mValToHs ptr,- mValObjBidi_hsToVal = \obj ptr -> flip mHsToVal ptr =<< newFn obj,- mValObjBidi_hsToAlloc = \obj f -> flip mHsToAlloc f =<< newFn obj,- mValObjBidi_objToHs = hsqmlObjectGetHaskell,- mValObjBidi_hsToObj = fmap objHndl . newFn}+-- | Represents a QML class which wraps the type @tt@.+newtype Class tt = Class HsQMLClassHandle +-- | Creates a new QML class for the type @tt@.+newClass :: forall tt. (Typeable tt) => [Member tt] -> IO (Class tt)+newClass = fmap Class . createClass (typeOf (undefined :: tt))++createClass :: forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle+createClass typRep ms = do+ hsqmlInit+ classId <- hsqmlGetNextClassId+ let constrs t = typeRepTyCon t : (concatMap constrs $ typeRepArgs t)+ name = foldr (\c s -> showString (tyConName c) .+ showChar '_' . s) id (constrs typRep) $ showInt classId ""+ ms' = ms ++ implicitSignals ms+ moc = compileClass name ms'+ sigs = filterMembers SignalMember ms'+ sigMap = Map.fromList $ flip zip [0..] $ map (fromJust . memberKey) sigs+ info = ClassInfo typRep sigMap+ maybeMarshalFunc = maybe (return nullFunPtr) marshalFunc+ metaDataPtr <- crlToNewArray return (mData moc)+ metaStrInfoPtr <- crlToNewArray return (mStrInfo moc)+ metaStrCharPtr <- crlToNewArray return (mStrChar moc)+ methodsPtr <- crlToNewArray maybeMarshalFunc (mFuncMethods moc)+ propsPtr <- crlToNewArray maybeMarshalFunc (mFuncProperties moc)+ maybeHndl <- hsqmlCreateClass+ metaDataPtr metaStrInfoPtr metaStrCharPtr info methodsPtr propsPtr+ case maybeHndl of+ Just hndl -> return hndl+ Nothing -> error ("Failed to create QML class '"++name++"'.")++implicitSignals :: [Member tt] -> [Member tt]+implicitSignals ms =+ let sigKeys = Set.fromList $ mapMaybe memberKey $+ filterMembers SignalMember ms+ impKeys = filter (flip Set.notMember sigKeys) $ mapMaybe memberKey $+ filterMembers PropertyMember ms+ impMember i k = Member SignalMember+ ("__implicitSignal" ++ show i)+ tyVoid+ []+ (\_ _ -> return ())+ Nothing+ (Just k)+ in map (uncurry impMember) $ zip [(0::Int)..] impKeys+ ----- ClassDef+-- Default Class -- --- | Generates a 'ClassDef' from a list of 'Member's.-defClass :: forall tt. (Object tt) => [Member tt] -> ClassDef tt-defClass = ClassDef- data MemoStore k v = MemoStore (MVar (Map k v)) (IORef (Map k v)) newMemoStore :: IO (MemoStore k v)@@ -230,110 +187,92 @@ writeIORef ir newMap return (newMap, (True, val)) -data ClassRec = ClassRec {- crecHndl :: HsQMLClassHandle,- crecSigs :: Map TypeRep Int-}+-- | The class 'DefaultClass' specifies a standard class definition for the+-- type @tt@.+class (Typeable tt) => DefaultClass tt where+ -- | List of default class members.+ classMembers :: [Member tt] -{-# NOINLINE classRecDb #-}-classRecDb :: MemoStore TypeRep ClassRec-classRecDb = unsafePerformIO $ newMemoStore+{-# NOINLINE defaultClassDb #-}+defaultClassDb :: MemoStore TypeRep HsQMLClassHandle+defaultClassDb = unsafePerformIO $ newMemoStore -getClassRec :: forall tt. (Object tt) => ClassDef tt -> IO ClassRec-getClassRec cdef = do+getDefaultClass :: forall tt. (DefaultClass tt) => IO (Class tt)+getDefaultClass = do let typ = typeOf (undefined :: tt)- (_, val) <- getFromMemoStore classRecDb typ (createClass typ cdef)- return val--createClass :: forall tt. (Object tt) => TypeRep -> ClassDef tt -> IO ClassRec-createClass typRep cdef = do- hsqmlInit- classId <- hsqmlGetNextClassId- let constrs t = typeRepTyCon t : (concatMap constrs $ typeRepArgs t)- name = foldr (\c s -> showString (tyConName c) .- showChar '_' . s) id (constrs typRep) $ showInt classId ""- ms = classMembers cdef- moc = compileClass name ms- sigs = filterMembers SignalMember ms- sigMap = Map.fromList $ flip zip [0..] $ map (fromJust . memberKey) sigs- maybeMarshalFunc = maybe (return nullFunPtr) marshalFunc- metaDataPtr <- crlToNewArray return (mData moc)- metaStrDataPtr <- crlToNewArray return (mStrData moc)- methodsPtr <- crlToNewArray maybeMarshalFunc (mFuncMethods moc)- propsPtr <- crlToNewArray maybeMarshalFunc (mFuncProperties moc)- maybeHndl <- hsqmlCreateClass- metaDataPtr metaStrDataPtr typRep methodsPtr propsPtr- case maybeHndl of- Just hndl -> return $ ClassRec hndl sigMap- Nothing -> error ("Failed to create QML class '"++name++"'.")+ (_, val) <- getFromMemoStore defaultClassDb typ $+ createClass typ (classMembers :: [Member tt])+ return (Class val) -- -- Method -- data MethodTypeInfo = MethodTypeInfo {- methodParamTypes :: [TypeName],- methodReturnType :: TypeName+ methodParamTypes :: [TypeId],+ methodReturnType :: TypeId } -newtype MSHelp a = MSHelp a- -- | Supports marshalling Haskell functions with an arbitrary number of -- arguments. class MethodSuffix a where mkMethodFunc :: Int -> a -> Ptr (Ptr ()) -> ErrIO () mkMethodTypes :: Tagged a MethodTypeInfo -instance (Marshal a, MarshalToHs (MarshalMode a), MethodSuffix (MSHelp b)) =>- MethodSuffix (MSHelp (a -> b)) where- mkMethodFunc n (MSHelp f) pv = do+instance (Marshal a, CanGetFrom a ~ Yes, MethodSuffix b) =>+ MethodSuffix (a -> b) where+ mkMethodFunc n f pv = do ptr <- errIO $ peekElemOff pv n- val <- mValToHs ptr- mkMethodFunc (n+1) (MSHelp $ f val) pv+ val <- mFromCVal ptr+ mkMethodFunc (n+1) (f val) pv return () mkMethodTypes = let (MethodTypeInfo p r) =- untag (mkMethodTypes :: Tagged (MSHelp b) MethodTypeInfo)- typ = untag (mTypeName :: Tagged a TypeName)+ untag (mkMethodTypes :: Tagged b MethodTypeInfo)+ typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ MethodTypeInfo (typ:p) r -instance (Marshal a, MarshalToValRaw (MarshalMode a)) =>- MethodSuffix (MSHelp (IO a)) where- mkMethodFunc _ (MSHelp f) pv = errIO $ do+instance (Marshal a, CanReturnTo a ~ Yes) =>+ MethodSuffix (IO a) where+ mkMethodFunc _ f pv = errIO $ do ptr <- peekElemOff pv 0 val <- f if nullPtr == ptr then return ()- else mHsToVal val ptr+ else mToCVal val ptr mkMethodTypes =- let typ = untag (mTypeName :: Tagged a TypeName)+ let typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ MethodTypeInfo [] typ mkUniformFunc :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) =>+ (Marshal tt,+ MethodSuffix ms) => (tt -> ms) -> UniformFunc mkUniformFunc f = \pt pv -> do- hndl <- hsqmlGetObjectHandle pt- this <- mObjToHs hndl- runErrIO $ mkMethodFunc 1 (MSHelp $ f this) pv+ hndl <- hsqmlGetObjectFromPointer pt+ this <- mFromHndl hndl+ runErrIO $ mkMethodFunc 1 (f this) pv newtype VoidIO = VoidIO {runVoidIO :: (IO ())} -instance MethodSuffix (MSHelp VoidIO) where- mkMethodFunc _ (MSHelp f) pv = errIO $ runVoidIO f- mkMethodTypes = Tagged $ MethodTypeInfo [] (TypeName "")+instance MethodSuffix VoidIO where+ mkMethodFunc _ f _ = errIO $ runVoidIO f+ mkMethodTypes = Tagged $ MethodTypeInfo [] tyVoid class IsVoidIO a instance (IsVoidIO b) => IsVoidIO (a -> b) instance IsVoidIO VoidIO -mkSpecialFunc :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms),- IsVoidIO ms) => (tt -> ms) -> UniformFunc+mkSpecialFunc+ :: forall tt ms.+ ( Marshal tt+ , MethodSuffix ms)+ => (tt -> ms)+ -> UniformFunc mkSpecialFunc f = \pt pv -> do- hndl <- hsqmlGetObjectHandle pt- this <- mObjToHs hndl- runErrIO $ mkMethodFunc 0 (MSHelp $ f this) pv+ hndl <- hsqmlGetObjectFromPointer pt+ this <- mFromHndl hndl+ runErrIO $ mkMethodFunc 0 (f this) pv -- | Defines a named method using a function @f@ in the IO monad. --@@ -342,121 +281,245 @@ -- there may be zero or more parameter arguments followed by an optional return -- argument in the IO monad. defMethod :: forall tt ms.- (Marshal tt, MarshalFromObj (MarshalMode tt), MethodSuffix (MSHelp ms)) =>- String -> (tt -> ms) -> Member (ThisObj tt)+ (Marshal tt, MethodSuffix ms) =>+ String -> (tt -> ms) -> Member (GetObjType tt) defMethod name f =- let crude = untag (mkMethodTypes :: Tagged (MSHelp ms) MethodTypeInfo)+ let crude = untag (mkMethodTypes :: Tagged ms MethodTypeInfo) in Member MethodMember name (methodReturnType crude)- (methodParamTypes crude)+ (map (\t->("",t)) $ methodParamTypes crude) (mkUniformFunc f) Nothing Nothing ------ Property------- | Defines a named read-only property using an accessor function in the IO--- monad.-defPropertyRO ::- forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),- Marshal tr, MarshalToVal (MarshalMode tr)) =>- String -> (tt -> IO tr) -> Member (ThisObj tt)-defPropertyRO name g = Member PropertyMember- name- (untag (mTypeName :: Tagged tr TypeName))- []- (mkUniformFunc g)- Nothing- Nothing---- | Defines a named read-write property using a pair of accessor and mutator--- functions in the IO monad.-defPropertyRW ::- forall tt tr. (Marshal tt, MarshalFromObj (MarshalMode tt),- Marshal tr, MarshalToHs (MarshalMode tr), MarshalToVal (MarshalMode tr)) =>- String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (ThisObj tt)-defPropertyRW name g s = Member PropertyMember- name- (untag (mTypeName :: Tagged tr TypeName))- []- (mkUniformFunc g)- (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))- Nothing+-- | Alias of 'defMethod' which is less polymorphic to reduce the need for type+-- signatures.+defMethod' :: forall obj ms. (Typeable obj, MethodSuffix ms) =>+ String -> (ObjRef obj -> ms) -> Member obj+defMethod' = defMethod -- -- Signal -- data SignalTypeInfo = SignalTypeInfo {- signalParamTypes :: [TypeName]+ signalParamTypes :: [TypeId] } --- | Defines a named signal using a 'SignalKey'.+-- | Defines a named signal. The signal is identified in subsequent calls to+-- 'fireSignal' using a 'SignalKeyValue'. This can be either i) type-based+-- using 'Proxy' @sk@ where @sk@ is an instance of the 'SignalKeyClass' class+-- or ii) value-based using a 'SignalKey' value creating using 'newSignalKey'. defSignal ::- forall obj sk. (Object obj, SignalKey sk) => Tagged sk String -> Member obj-defSignal tn =- let crude = untag (mkSignalTypes :: Tagged (SignalParams sk) SignalTypeInfo)- in Member SignalMember- (untag tn)- (TypeName "")- (signalParamTypes crude)- (\_ _ -> return ())- Nothing- (Just $ typeOf (undefined :: sk))+ forall obj skv. (SignalKeyValue skv) => String -> skv -> Member obj+defSignal name key = defSignalNamedParams name key anonParams --- | Fires a signal on an 'Object', specified using a 'SignalKey'.+-- | Defines a named signal with named parameters. This is otherwise identical+-- to 'defSignal', but allows QML code to reference signal parameters by-name+-- in addition to by-position.+defSignalNamedParams :: forall obj skv. (SignalKeyValue skv) =>+ String -> skv ->+ ParamNames (SignalParamNames (SignalValueParams skv)) -> Member obj+defSignalNamedParams name key pnames =+ let crude = untag (mkSignalTypes ::+ Tagged (SignalValueParams skv) SignalTypeInfo)+ in Member SignalMember+ name+ tyVoid+ (paramNames pnames `zip` signalParamTypes crude)+ (\_ _ -> return ())+ Nothing+ (Just $ signalKey key)++-- | Fires a signal defined on an object instance. The signal is identified+-- using either a type- or value-based signal key, as described in the+-- documentation for 'defSignal'. The first argument is the signal key, the+-- second is the object, and the remaining arguments, if any, are the arguments+-- to the signal as specified by the signal key.+--+-- If this function is called using a signal key which doesn't match a signal+-- defined on the supplied object, it will silently do nothing.+--+-- 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 sk. (- Marshal tt, MarshalToObj (MarshalMode tt),- Object (ThisObj tt), SignalKey sk) =>- Tagged sk tt -> SignalParams sk -fireSignal this =- let start cnt = do- crec <- getClassRec (classDef :: ClassDef (ThisObj tt))- let keyRep = typeOf (undefined :: sk)- slotMay = Map.lookup keyRep $ crecSigs crec+ forall tt skv. (Marshal tt,+ SignalKeyValue skv) => skv -> tt -> SignalValueParams skv+fireSignal key this =+ let start cnt = postJob $ do+ hndl <- mToHndl this+ info <- hsqmlObjectGetHsTyperep hndl+ let slotMay = Map.lookup (signalKey key) $ cinfoSignals info case slotMay of- Just slotIdx -> postJob $ do- hndl <- mHsToObj $ untag this+ Just slotIdx -> withActiveObject hndl $ cnt $ SignalData hndl slotIdx Nothing ->- error ("Attempt to fire undefined signal on class '"++- (typeName $ untag (mTypeName :: Tagged tt TypeName))++"'.")- cont ps (SignalData hndl slotIdx) =- withArray (nullPtr:ps) (\pptr ->+ return () -- Should warn?+ cont ps (SignalData hndl slotIdx) =+ withArray (nullPtr:ps) (\pptr -> hsqmlFireSignal hndl slotIdx pptr) in mkSignalArgs start cont data SignalData = SignalData HsQMLObjectHandle Int --- | Instances of the 'SignalKey' class identify distinct signals. The--- associated 'SignalParams' type specifies the signal's signature.-class (SignalSuffix (SignalParams sk), Typeable sk) => SignalKey sk where- type SignalParams sk+-- | Values of the type 'SignalKey' identify distinct signals by value. The+-- type parameter @p@ specifies the signal's signature.+newtype SignalKey p = SignalKey Unique +-- | Creates a new 'SignalKey'. +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.+class (SignalSuffix (SignalParams sk)) => SignalKeyClass sk where+ type SignalParams sk++class (SignalSuffix (SignalValueParams skv)) => SignalKeyValue skv where+ type SignalValueParams skv+ signalKey :: skv -> MemberKey++instance (SignalKeyClass sk, Typeable sk) => SignalKeyValue (Proxy sk) where+ type SignalValueParams (Proxy sk) = SignalParams sk+ signalKey _ = TypeKey $ typeOf (undefined :: sk)++instance (SignalSuffix p) => SignalKeyValue (SignalKey p) where+ type SignalValueParams (SignalKey p) = p+ signalKey (SignalKey u) = DataKey u+ -- | Supports marshalling an arbitrary number of arguments into a QML signal.-class SignalSuffix ss where+class (AnonParams (SignalParamNames ss)) => SignalSuffix ss where+ type SignalParamNames ss mkSignalArgs :: forall usr. ((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss mkSignalTypes :: Tagged ss SignalTypeInfo -instance (Marshal a, MarshalToVal (MarshalMode a), SignalSuffix b) =>+instance (Marshal a, CanPassTo a ~ Yes, SignalSuffix b) => SignalSuffix (a -> b) where+ type SignalParamNames (a -> b) = String -> SignalParamNames b mkSignalArgs start cont param = mkSignalArgs start (\ps usr ->- mHsToAlloc param (\ptr ->+ mWithCVal param (\ptr -> cont (ptr:ps) usr)) mkSignalTypes = let (SignalTypeInfo p) = untag (mkSignalTypes :: Tagged b SignalTypeInfo)- typ = untag (mTypeName :: Tagged a TypeName)+ typ = untag (mTypeCVal :: Tagged a TypeId) in Tagged $ SignalTypeInfo (typ:p) instance SignalSuffix (IO ()) where+ type SignalParamNames (IO ()) = () mkSignalArgs start cont = start $ cont [] mkSignalTypes = Tagged $ SignalTypeInfo []++--+-- Property+--++-- | Defines a named constant property using an accessor function in the IO+-- monad.+defPropertyConst :: forall tt tr.+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes) => String ->+ (tt -> IO tr) -> Member (GetObjType tt)+defPropertyConst name g = Member ConstPropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ Nothing+ Nothing++-- | Defines a named read-only property using an accessor function in the IO+-- monad.+defPropertyRO :: forall tt tr.+ (Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,+ CanReturnTo tr ~ Yes) => String ->+ (tt -> IO tr) -> Member (GetObjType tt)+defPropertyRO name g = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ Nothing+ Nothing++-- | Defines a named read-only property with an associated signal.+defPropertySigRO :: forall tt tr skv.+ (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+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ Nothing+ (Just $ signalKey key)++-- | 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, Marshal tr,+ CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) => String ->+ (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (GetObjType tt)+defPropertyRW name g s = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))+ Nothing++-- | Defines a named read-write property with an associated signal.+defPropertySigRW :: forall tt tr skv.+ (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)+defPropertySigRW name key g s = Member PropertyMember+ name+ (untag (mTypeCVal :: Tagged tr TypeId))+ []+ (mkUniformFunc g)+ (Just $ mkSpecialFunc (\a b -> VoidIO $ s a b))+ (Just $ signalKey key)++-- | Alias of 'defPropertyConst' which is less polymorphic to reduce the need+-- for type signatures.+defPropertyConst' :: forall obj tr.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>+ String -> (ObjRef obj -> IO tr) -> Member obj+defPropertyConst' = defPropertyConst++-- | Alias of 'defPropertyRO' which is less polymorphic to reduce the need for+-- type signatures.+defPropertyRO' :: forall obj tr.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>+ String -> (ObjRef obj -> IO tr) -> Member obj+defPropertyRO' = defPropertyRO++-- | Alias of 'defPropertySigRO' which is less polymorphic to reduce the need+-- for type signatures.+defPropertySigRO' :: forall obj tr skv.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, SignalKeyValue skv) =>+ String -> skv -> (ObjRef obj -> IO tr) -> Member obj+defPropertySigRO' = defPropertySigRO++-- | Alias of 'defPropertyRW' which is less polymorphic to reduce the need for+-- type signatures.+defPropertyRW' :: forall obj tr.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes) =>+ String -> (ObjRef obj -> IO tr) -> (ObjRef obj -> tr -> IO ()) -> Member obj+defPropertyRW' = defPropertyRW++-- | Alias of 'defPropertySigRW' which is less polymorphic to reduce the need+-- for type signatures.+defPropertySigRW' :: forall obj tr skv.+ (Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, CanGetFrom tr ~ Yes,+ SignalKeyValue skv) => String -> skv ->+ (ObjRef obj -> IO tr) -> (ObjRef obj -> tr -> IO ()) -> Member obj+defPropertySigRW' = defPropertySigRW
+ src/Graphics/QML/Objects/ParamNames.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE+ ScopedTypeVariables,+ FlexibleInstances+ #-}++-- | Parameter Name Lists+module Graphics.QML.Objects.ParamNames (+ ParamNames,+ paramNames,+ noNames,+ fstName,+ plusName,+ anonParams,+ AnonParams ()+) where++-- | Represents a list of parameter names. The number of names in the list is+-- statically encoded using the length of the function type held in the type+-- parameter @a@.+newtype ParamNames a = ParamNames ([String] -> [String])++instance Show (ParamNames a) where+ show (ParamNames nsFunc) =+ let showHead [] = showString "noNames"+ showHead (n:ns) = showString "fstName " . shows n . showTail ns+ showTail [] = id+ showTail (n:ns) = showString " `plusName` " . shows n . showTail ns+ in showHead (nsFunc []) ""++-- | Coverts a 'ParamNames' list to an ordinary list of strings.+paramNames :: ParamNames a -> [String]+paramNames (ParamNames names) = names []++-- | Adds one parameter name to a 'ParamNames' list.+plusName :: ParamNames a -> String -> ParamNames (String -> a)+plusName (ParamNames ns) n = ParamNames $ ns . (n:)++-- | An empty 'ParamNames' list.+noNames :: ParamNames ()+noNames = ParamNames id++-- | Produces a 'ParamNames' list with a single name.+fstName :: String -> ParamNames (String -> ())+fstName = (noNames `plusName`)++-- | Helper class for generating anonymous parameter lists.+class AnonParams a where+ anonParams_ :: ParamNames a++instance (AnonParams b) => AnonParams (String -> b) where+ anonParams_ = plusName (anonParams_ :: ParamNames b) ""++instance AnonParams () where+ anonParams_ = noNames++-- | Polymorphically produces 'ParamNames' lists of any length filled with+-- blank parameter names.+anonParams :: (AnonParams a) => ParamNames a+anonParams = anonParams_
+ src/Graphics/QML/Objects/Weak.hs view
@@ -0,0 +1,120 @@+-- | Facilities for working with weak references, finalisers, and factory+-- pools.+module Graphics.QML.Objects.Weak (+ -- * Weak Object References+ WeakObjRef,+ toWeakObjRef,+ fromWeakObjRef,++ -- * Object Finalisers+ ObjFinaliser,+ newObjFinaliser,+ addObjFinaliser,++ -- * Factory Pools+ FactoryPool,+ newFactoryPool,+ getPoolObject+) where++import Graphics.QML.Internal.BindObj+import Graphics.QML.Internal.Objects++import Control.Concurrent.MVar+import qualified Data.Map as Map+import Data.Map (Map)++-- | Represents a weak reference to a QML object which wraps the type @tt@.+--+-- Unlike ordinary strong references, a weak reference does not prevent the+-- QML garbage collector from collecting the underlying object. Weak references+-- can be used to monitor the life cycles of QML objects.+newtype WeakObjRef tt = WeakObjRef HsQMLObjectHandle++-- | Converts a strong 'ObjRef' into a 'WeakObjRef'. +toWeakObjRef :: ObjRef tt -> IO (WeakObjRef tt)+toWeakObjRef (ObjRef hndl) = do+ hndl' <- copyObjectHandle hndl True+ return $ WeakObjRef hndl'++-- | Converts a 'WeakObjRef' into a strong 'ObjRef'.+--+-- If the underlying QML object has already been collected then the resulting+-- 'ObjRef' can be used to reincarnate it.+fromWeakObjRef :: WeakObjRef tt -> IO (ObjRef tt)+fromWeakObjRef (WeakObjRef hndl) = do+ hndl' <- copyObjectHandle hndl False+ return $ ObjRef hndl'++-- | Represents an object finaliser function for QML objects which wrap the+-- type @tt@.+data ObjFinaliser tt = ObjFinaliser HsQMLObjFinaliserHandle++-- | Create a new object finaliser from a finaliser function.+--+-- Note that at the time the finaliser is called the runtime will have already+-- comitted to collecting the underlying QML object. The 'ObjRef' passed into+-- the finaliser can be used to reincarnate the object, but this QML object+-- will have a distinct identity to the original.+newObjFinaliser :: (ObjRef tt -> IO ()) -> IO (ObjFinaliser tt)+newObjFinaliser f = do+ fPtr <- marshalObjFinaliser $ \hPtr -> do+ hndl <- newObjectHandle hPtr+ f $ ObjRef hndl+ final <- hsqmlCreateObjFinaliser fPtr+ return $ ObjFinaliser final++-- | Adds an object finaliser to an QML object.+--+-- The finaliser will be called no more than once for each time it was added to+-- an object. The timing of finaliser execution is subject to the combined+-- behaviour of the Haskell and QML garbage collectors. All outstanding+-- finalisers will be run when the QML engine is terminated provided that the+-- program does not prematurely exit.+addObjFinaliser :: ObjFinaliser tt -> ObjRef tt -> IO ()+addObjFinaliser (ObjFinaliser final) (ObjRef hndl) =+ hsqmlObjectAddFinaliser hndl final++-- | Represents an object factory which maintains a one-to-one mapping between+-- values of type @tt@ and QML object instances.+--+-- 'ObjRef's manufactured by the pool are cached using the wrapped type @tt@ as+-- the lookup key in an ordered map. The pool uses weak references to+-- automatically purge objects which no longer have any strong references+-- leading to them from either Haskell or QML code.++-- Hence, the pool guarantees that if QML code is using a pool object (e.g. as+-- a source for data binding) then the same object instance can be obtained+-- again from the pool. Conversely, if an object instance is no longer being+-- used then pool will not prevent it from being garbage collected.+data FactoryPool tt = FactoryPool {+ factory_ :: tt -> IO (ObjRef tt),+ pool_ :: MVar (Map tt (WeakObjRef tt)),+ finaliser_ :: ObjFinaliser tt+}++-- | Creates a new 'FactoryPool' using the supplied factory function.+newFactoryPool :: (Ord tt) =>+ (tt -> IO (ObjRef tt)) -> IO (FactoryPool tt)+newFactoryPool factory = do+ pool <- newMVar Map.empty+ finaliser <- newObjFinaliser $ \obj -> do+ value <- fromObjRefIO obj+ modifyMVar_ pool (return . Map.delete value)+ return $ FactoryPool factory pool finaliser++-- | Return the pool's canonical QML object for a value of @tt@, either by+-- creating it or looking it up in the pool's cache of objects.+getPoolObject :: (Ord tt) =>+ FactoryPool tt -> tt -> IO (ObjRef tt)+getPoolObject (FactoryPool factory pool finaliser) value =+ modifyMVar pool $ \pmap ->+ case Map.lookup value pmap of+ Just wkObj -> do+ obj <- fromWeakObjRef wkObj+ return (pmap, obj)+ Nothing -> do+ obj <- factory value+ addObjFinaliser finaliser obj+ wkObj <- toWeakObjRef obj+ return (Map.insert value wkObj pmap, obj)
+ 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/DataTest.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies #-}++module Graphics.QML.Test.DataTest where++import Graphics.QML.Marshal+import Graphics.QML.Objects+import Graphics.QML.Test.Framework+import Graphics.QML.Test.MayGen+import qualified Graphics.QML.Test.ScriptDSL as S++import Test.QuickCheck.Arbitrary+import Control.Applicative+import Data.Typeable++data DataTest a+ = DTCallMethod a+ | DTMethodRet a+ | DTReadProp a+ | DTWriteProp a+ deriving (Eq, Show, Typeable)++instance (Eq a, Show a, Typeable a, S.Literal a, Arbitrary a, MakeDefault a,+ Marshal a, CanPassTo a ~ Yes, CanReturnTo a ~ Yes, CanGetFrom a ~ Yes)+ => TestAction (DataTest a) where+ legalActionIn _ _ = True + nextActionsFor _ = mayOneof [+ DTCallMethod <$> fromGen arbitrary,+ DTMethodRet <$> fromGen arbitrary,+ DTReadProp <$> fromGen arbitrary,+ DTWriteProp <$> fromGen arbitrary]+ updateEnvRaw _ = testEnvStep+ actionRemote (DTCallMethod v) n =+ S.eval $ S.var n `S.dot` "callMethod" `S.call` [S.literal v]+ actionRemote (DTMethodRet v) n =+ S.assert $ S.deepEq (S.var n `S.dot` "methodRet" `S.call` []) $+ S.literal v+ actionRemote (DTReadProp v) n =+ S.assert $ S.deepEq (S.var n `S.dot` "readProp") $ S.literal v+ actionRemote (DTWriteProp v) n =+ S.var n `S.dot` "writeProp" `S.set` S.literal v+ mockObjDef = [+ defMethod "methodRet" $ \m -> expectAction m $ \a -> case a of+ DTMethodRet v -> return $ Right v+ _ -> return $ Left TBadActionCtor,+ defMethod "callMethod" $ \m v ->+ checkAction m (DTCallMethod v) $ return (),+ defPropertyRW "readProp"+ (\m -> expectAction m $ \a -> case a of+ DTReadProp v -> return $ Right v+ _ -> return $ Left TBadActionCtor)+ (\m _ -> badAction m),+ defPropertyRW "writeProp"+ (\_ -> makeDef) (\m v -> checkAction m (DTWriteProp v) $ return ())]
test/Graphics/QML/Test/Framework.hs view
@@ -26,7 +26,6 @@ import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI data TestType = forall a. (TestAction a) => TestType (Proxy a) @@ -203,11 +202,14 @@ makeDef = do statusRef <- newIORef $ TestStatus [] (Just TInvalid) (TestEnv badSerial IntMap.empty IntMap.empty) IntMap.empty- newObject $ MockObj badSerial statusRef+ newObjectDC $ MockObj badSerial statusRef instance MakeDefault () where makeDef = return () +instance MakeDefault Bool where+ makeDef = return False+ instance MakeDefault Int32 where makeDef = return 0 @@ -220,8 +222,8 @@ instance MakeDefault Text where makeDef = return T.empty -instance MakeDefault URI where- makeDef = return $ URI "" Nothing "" "" ""+instance MakeDefault (Maybe a) where+ makeDef = return Nothing expectAction :: (TestAction a, MakeDefault b) => MockObj a -> (a -> IO (Either TestFault b)) -> IO b@@ -248,6 +250,17 @@ ObjRef (MockObj a) -> (a -> IO (Either TestFault b)) -> IO b expectActionRef ref pred = expectAction (fromObjRef ref) pred +checkAction :: (TestAction a, Eq a, MakeDefault b) =>+ MockObj a -> a -> IO b -> IO b+checkAction mock action next = expectAction mock $ \expected -> do+ if expected == action+ then fmap Right $ next+ else return . Left $+ if fakeToConstr expected /= fakeToConstr action+ then TBadActionCtor+ else TBadActionData+ where fakeToConstr = takeWhile (/= ' ') . show+ badAction :: (MakeDefault b) => MockObj a -> IO b badAction mock = do status <- readIORef $ mockStatus mock@@ -257,7 +270,7 @@ forkMockObj :: (TestAction b) => MockObj a -> IO (ObjRef (MockObj b)) forkMockObj m = do status <- mockGetStatus m- newObject $ MockObj (testSerial status) $ mockStatus m+ newObjectDC $ MockObj (testSerial status) $ mockStatus m checkMockObj :: forall a b. (TestAction b) => MockObj a -> MockObj b -> Int -> IO (Either TestFault ())@@ -269,9 +282,9 @@ else return $ Left TBadActionData _ -> return $ Left TBadActionSlot -instance (TestAction a) => Object (MockObj a) where- classDef = defClass mockObjDef+instance (TestAction a) => DefaultClass (MockObj a) where+ classMembers = mockObjDef instance (TestAction a) => Marshal (MockObj a) where- type MarshalMode (MockObj a) = ValObjToOnly (MockObj a)- marshaller = objSimpleMarshaller+ type MarshalMode (MockObj a) c d = ModeObjFrom (MockObj a) c+ marshaller = fromMarshaller fromObjRef
− test/Graphics/QML/Test/GenURI.hs
@@ -1,51 +0,0 @@-module Graphics.QML.Test.GenURI where--import Test.QuickCheck.Gen-import Network.URI-import Numeric--capSize :: Int -> Gen a -> Gen a-capSize cap g = sized (\s -> if s > cap then resize cap g else resize s g)--uriGen :: Gen URI-uriGen = capSize 35 $ do- let slists = fmap (:[])- listxyz = fmap concat . sequence- listxs = fmap concat . listOf- listxs1 = fmap concat . listOf1- lower = elements $ slists $ enumFromTo 'a' 'z'- upper = elements $ slists $ enumFromTo 'A' 'Z'- digit = elements $ slists "01234567989"- mark = elements $ slists "-_.!~*'()"- sextra = elements $ slists "+-."- rextra = elements $ slists "$,;:@&=+"- dash = return "-"- dot = return "."- alpha = oneof [lower, upper]- alphnum = oneof [lower, upper, digit]- dchar = oneof [lower, digit]- dchar2 = frequency [(9,lower), (5,digit), (1,dash)]- unres = frequency [(9,alphnum), (1,mark)]- escNum = oneof [choose (0,31), choose (128,255)] :: Gen Int- pad = \n x -> replicate (n - length x) '0' ++ x- escape = fmap (('%':) . pad 2 . flip showHex "") escNum- scheme = listxyz [alpha, listxs $ frequency [- (9,alphnum), (1,sextra)]]- dpart1 = listxyz [- frequency [(9,dchar), (1,listxyz [dchar, dot, dchar])],- listxs $ frequency [- (9,dchar2), (1,listxyz [dchar, dot, dchar]),- (1,listxyz [dchar, dot, dchar, dot, dchar])],- dchar, dot]- dpart2 = oneof [lower, listxyz [lower, listxs dchar2, dchar]]- regName = flip suchThat (\x -> length x < 255) $ listxyz [- frequency [(9,dpart1), (1,return "")],- dpart2, oneof [dot, return ""]]- segment = fmap ('/':) $ listxs $ frequency [- (9,unres), (1,escape), (1,rextra)]- path = listxs1 segment- schemeStr <- scheme- regNameStr <- regName- pathStr <- path- return $- URI (schemeStr++":") (Just $ URIAuth "" regNameStr "") pathStr "" ""
test/Graphics/QML/Test/Harness.hs view
@@ -16,12 +16,21 @@ qmlPrelude :: String qmlPrelude = unlines [- "import Qt 4.7",- "Rectangle {",- " id: page;",- " width: 100; height: 100;",- " color: 'green';",- " Component.onCompleted: {"]+ "import QtQuick 2.0",+ "import QtQuick.Window 2.0",+ "import HsQML.Model 1.0",+ "Window {",+ " id: page; visible: false;",+ " Component.onCompleted: {",+ " function deepEq(a, b) {",+ " if (a === b) {return true;}",+ " if (typeof a == 'object' && typeof b == 'object') {",+ " var ak = Object.keys(a); var bk = Object.keys(b);",+ " if (ak.length != bk.length) {return false;}",+ " for (var i=0; i<ak.length; i++) {",+ " if (!deepEq(a[ak[i]], b[ak[i]])) {return false;}}",+ " return true;}",+ " return false;}"] qmlPostscript :: String qmlPostscript = unlines [@@ -46,10 +55,9 @@ hPutStr hndl (qmlPrelude ++ js ++ qmlPostscript) hClose hndl mock <- mockFromSrc src- go <- newObject mock+ go <- newObjectDC mock runEngineLoop defaultEngineConfig {- initialURL = filePathToURI qmlPath,- initialWindowState = HideWindow,+ initialDocument = fileDocument qmlPath, contextObject = Just $ anyObjRef go} removeFile qmlPath finishTest mock@@ -65,10 +73,11 @@ assert $ isNothing $ testFault status return () -checkProperty :: TestType -> IO Bool-checkProperty (TestType pxy) = do+checkProperty :: Int -> TestType -> IO Bool+checkProperty n (TestType pxy) = do putStrLn $ "Checking " ++ show (typeOf $ asProxyTypeOf undefined pxy)- r <- quickCheckResult $ testProperty . constrainSrc pxy+ let args = stdArgs {maxSuccess = n}+ r <- quickCheckWithResult args $ testProperty . constrainSrc pxy return $ isSuccess r constrainSrc :: (TestAction a) => Proxy a -> TestBoxSrc a -> TestBoxSrc a
test/Graphics/QML/Test/ScriptDSL.hs view
@@ -1,23 +1,34 @@-{-# 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 Network.URI import Numeric data Expr = Global | Expr {unExpr :: ShowS} 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@@ -25,6 +36,10 @@ class Literal a where literal :: a -> Expr +instance Literal Bool where+ literal True = Expr $ showString "true"+ literal False = Expr $ showString "false"+ instance Literal Int where literal x = Expr $ shows x @@ -38,24 +53,32 @@ | isNegativeZero x = Expr $ showString "-0" | otherwise = Expr $ shows x -instance Literal [Char] where- literal [] = Expr $ showString "\"\""- literal cs =- Expr (showChar '"' . (foldr1 (.) $ map f cs) . showChar '"')+instance Literal Text where+ literal txt =+ Expr (showChar '"' . (+ 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 Text where- literal = literal . T.unpack+instance Literal a => Literal (Maybe a) where+ literal Nothing = Expr $ showString "null"+ literal (Just v) = literal v -instance Literal URI where- literal = literal . ($ "") . uriToString id+instance Literal a => Literal [a] where+ literal xs = Expr (showChar '[' . (+ foldr (.) id . intersperse (showChar ',') $ map (unExpr . literal) xs) .+ showChar ']') var :: Int -> Expr var 0 = Global@@ -71,7 +94,7 @@ call :: Expr -> [Expr] -> Expr call (Expr f) ps = Expr ( f . showChar '(' . (- foldr1 (.) $ (id:) $ intersperse (showChar ',') $ map unExpr ps) .+ foldr (.) id $ intersperse (showChar ',') $ map unExpr ps) . showChar ')') call _ _ = error "cannot call the context object" @@ -86,6 +109,9 @@ neq :: Expr -> Expr -> Expr neq = binOp " != " +deepEq :: Expr -> Expr -> Expr+deepEq a b = call (sym "deepEq") [a, b]+ eval :: Expr -> Prog eval (Expr ex) = Prog (ex . showString ";\n") id eval _ = error "cannot eval the context object"@@ -104,7 +130,7 @@ assert :: Expr -> Prog assert (Expr ex) = Prog (showString "if (!" . ex .- showString ") {window.close(); throw -1;}\n") id+ showString ") {Qt.quit(); throw -1;}\n") id assert _ = error "cannot assert the context object" connect :: Expr -> Expr -> Prog@@ -113,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 @@ -127,4 +153,4 @@ callee = sym "arguments.callee" end :: Prog-end = Prog (showString "window.close();\n") id+end = Prog (showString "Qt.quit();\n") id
test/Graphics/QML/Test/SignalTest.hs view
@@ -5,7 +5,6 @@ import Graphics.QML.Objects import Graphics.QML.Test.Framework import Graphics.QML.Test.MayGen-import Graphics.QML.Test.GenURI import Graphics.QML.Test.TestObject import Graphics.QML.Test.ScriptDSL (Expr, Prog) import qualified Graphics.QML.Test.ScriptDSL as S@@ -13,13 +12,12 @@ import Test.QuickCheck.Arbitrary import Control.Applicative import Data.Monoid-import Data.Tagged+import Data.Proxy import Data.Typeable import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI data SignalTest1 = ST1TrivialMethod@@ -27,57 +25,45 @@ | ST1FireInt Int32 | ST1FireThreeInts Int32 Int32 Int32 | ST1FireDouble Double- | ST1FireString String | ST1FireText Text- | ST1FireURI URI | ST1FireObject Int | ST1CheckObject Int deriving (Show, Typeable) data NoArgsSignal deriving Typeable -instance SignalKey NoArgsSignal where+instance SignalKeyClass NoArgsSignal where type SignalParams NoArgsSignal = IO () data IntSignal deriving Typeable -instance SignalKey IntSignal where+instance SignalKeyClass IntSignal where type SignalParams IntSignal = Int32 -> IO () data ThreeIntsSignal deriving Typeable -instance SignalKey ThreeIntsSignal where+instance SignalKeyClass ThreeIntsSignal where type SignalParams ThreeIntsSignal = Int32 -> Int32 -> Int32 -> IO () data DoubleSignal deriving Typeable -instance SignalKey DoubleSignal where+instance SignalKeyClass DoubleSignal where type SignalParams DoubleSignal = Double -> IO () -data StringSignal deriving Typeable--instance SignalKey StringSignal where- type SignalParams StringSignal = String -> IO ()- data TextSignal deriving Typeable -instance SignalKey TextSignal where+instance SignalKeyClass TextSignal where type SignalParams TextSignal = Text -> IO () -data URISignal deriving Typeable--instance SignalKey URISignal where- type SignalParams URISignal = URI -> IO ()- data ObjectSignal deriving Typeable -instance SignalKey ObjectSignal where+instance SignalKeyClass ObjectSignal where type SignalParams ObjectSignal = ObjRef (MockObj TestObject) -> IO () 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@@ -94,9 +80,7 @@ ST1FireThreeInts <$> fromGen arbitrary <*> fromGen arbitrary <*> fromGen arbitrary, ST1FireDouble <$> fromGen arbitrary,- ST1FireString <$> fromGen arbitrary, ST1FireText . T.pack <$> fromGen arbitrary,- ST1FireURI <$> fromGen uriGen, pure . ST1FireObject $ testEnvNextJ env, ST1CheckObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (ST1FireObject n) = testEnvStep . testEnvSerial (\s ->@@ -116,12 +100,8 @@ (S.assert $ S.sym "arg3" `S.eq` S.literal v3) actionRemote (ST1FireDouble v) n = testSignal n "doubleSignal" "fireDouble" $ S.literal v- actionRemote (ST1FireString v) n =- testSignal n "stringSignal" "fireString" $ S.literal v actionRemote (ST1FireText v) n = testSignal n "textSignal" "fireText" $ S.literal v- actionRemote (ST1FireURI v) n =- testSignal n "uriSignal" "fireURI" $ S.literal v actionRemote (ST1FireObject v) n = chainSignal n ["obj"] "objectSignal" "fireObject" `mappend` (S.saveVar v $ S.sym "obj")@@ -133,63 +113,41 @@ _ -> return $ Left TBadActionCtor, defMethod "fireNoArgs" $ \m -> (expectActionRef m $ \a -> case a of ST1FireNoArgs -> do- fireSignal (Tagged m- :: Tagged NoArgsSignal (ObjRef (MockObj SignalTest1)))+ fireSignal (Proxy :: Proxy NoArgsSignal) m return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "noArgsSignal" :: Tagged NoArgsSignal String), + defSignal "noArgsSignal" (Proxy :: Proxy NoArgsSignal), defMethod "fireInt" $ \m -> (expectActionRef m $ \a -> case a of ST1FireInt v -> do- fireSignal (Tagged m- :: Tagged IntSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy IntSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "intSignal" :: Tagged IntSignal String),+ defSignal "intSignal" (Proxy :: Proxy IntSignal), defMethod "fireThreeInts" $ \m -> (expectActionRef m $ \a -> case a of ST1FireThreeInts v1 v2 v3 -> do- fireSignal (Tagged m- :: Tagged ThreeIntsSignal (ObjRef (MockObj SignalTest1)))- v1 v2 v3+ fireSignal (Proxy :: Proxy ThreeIntsSignal) m v1 v2 v3 return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "threeIntsSignal" ::- Tagged ThreeIntsSignal String),+ defSignal "threeIntsSignal" (Proxy :: Proxy ThreeIntsSignal), defMethod "fireDouble" $ \m -> (expectActionRef m $ \a -> case a of ST1FireDouble v -> do- fireSignal (Tagged m- :: Tagged DoubleSignal (ObjRef (MockObj SignalTest1))) v- return $ Right ()- _ -> return $ Left TBadActionCtor),- defSignal (Tagged "doubleSignal" :: Tagged DoubleSignal String),- defMethod "fireString" $ \m -> (expectActionRef m $ \a -> case a of- ST1FireString v -> do- fireSignal (Tagged m- :: Tagged StringSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy DoubleSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "stringSignal" :: Tagged StringSignal String),+ defSignal "doubleSignal" (Proxy :: Proxy DoubleSignal), defMethod "fireText" $ \m -> (expectActionRef m $ \a -> case a of ST1FireText v -> do- fireSignal (Tagged m- :: Tagged TextSignal (ObjRef (MockObj SignalTest1))) v+ fireSignal (Proxy :: Proxy TextSignal) m v return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "textSignal" :: Tagged TextSignal String),- defMethod "fireURI" $ \m -> (expectActionRef m $ \a -> case a of- ST1FireURI v -> do- fireSignal (Tagged m- :: Tagged URISignal (ObjRef (MockObj SignalTest1))) v- return $ Right ()- _ -> return $ Left TBadActionCtor),- defSignal (Tagged "uriSignal" :: Tagged URISignal String),+ defSignal "textSignal" (Proxy :: Proxy TextSignal), defMethod "fireObject" $ \m -> (expectActionRef m $ \a -> case a of ST1FireObject _ -> do (Right obj) <- getTestObject $ fromObjRef m- fireSignal (Tagged m- :: Tagged ObjectSignal (ObjRef (MockObj SignalTest1))) obj+ fireSignal (Proxy :: Proxy ObjectSignal) m obj return $ Right () _ -> return $ Left TBadActionCtor),- defSignal (Tagged "objectSignal" :: Tagged ObjectSignal String),+ defSignal "objectSignal" (Proxy :: Proxy ObjectSignal), defMethod "checkObject" $ \m v -> expectAction m $ \a -> case a of ST1CheckObject w -> setTestObject m v w _ -> return $ Left TBadActionCtor]
test/Graphics/QML/Test/SimpleTest.hs view
@@ -5,7 +5,6 @@ import Graphics.QML.Objects import Graphics.QML.Test.Framework import Graphics.QML.Test.MayGen-import Graphics.QML.Test.GenURI import Graphics.QML.Test.TestObject import Graphics.QML.Test.ScriptDSL (Expr, Prog) import qualified Graphics.QML.Test.ScriptDSL as S@@ -17,7 +16,6 @@ import Data.Int import Data.Text (Text) import qualified Data.Text as T-import Network.URI makeCall :: Int -> String -> [Expr] -> Prog makeCall n name es = S.eval $ S.var n `S.dot` name `S.call` es@@ -41,6 +39,9 @@ checkArg v w = return $ if v == w then Right () else Left TBadActionData +retVoid :: IO ()+retVoid = return ()+ data SimpleMethods = SMTrivial | SMTernary Int32 Int32 Int32 Int32@@ -48,15 +49,11 @@ | SMSetInt Int32 | SMGetDouble Double | SMSetDouble Double- | SMGetString String- | SMSetString String | SMGetText Text | SMSetText Text- | SMGetURI URI- | SMSetURI URI | SMGetObject Int | SMSetObject Int- deriving (Show, Typeable)+ deriving (Eq, Show, Typeable) instance TestAction SimpleMethods where legalActionIn (SMSetObject n) env = testEnvIsaJ n testObjectType env@@ -70,12 +67,8 @@ SMSetInt <$> fromGen arbitrary, SMGetDouble <$> fromGen arbitrary, SMSetDouble <$> fromGen arbitrary,- SMGetString <$> fromGen arbitrary,- SMSetString <$> fromGen arbitrary, SMGetText . T.pack <$> fromGen arbitrary, SMSetText . T.pack <$> fromGen arbitrary,- SMGetURI <$> fromGen uriGen,- SMSetURI <$> fromGen uriGen, pure . SMGetObject $ testEnvNextJ env, SMSetObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (SMGetObject n) = testEnvStep . testEnvSerial (\s ->@@ -88,18 +81,12 @@ actionRemote (SMSetInt v) n = makeCall n "setInt" [S.literal v] actionRemote (SMGetDouble v) n = testCall n "getDouble" [] $ S.literal v actionRemote (SMSetDouble v) n = makeCall n "setDouble" [S.literal v]- actionRemote (SMGetString v) n = testCall n "getString" [] $ S.literal v- actionRemote (SMSetString v) n = makeCall n "setString" [S.literal v] actionRemote (SMGetText v) n = testCall n "getText" [] $ S.literal v actionRemote (SMSetText v) n = makeCall n "setText" [S.literal v]- actionRemote (SMGetURI v) n = testCall n "getURI" [] $ S.literal v- actionRemote (SMSetURI v) n = makeCall n "setURI" [S.literal v] actionRemote (SMGetObject v) n = saveCall v n "getObject" [] actionRemote (SMSetObject v) n = makeCall n "setObject" [S.var v] mockObjDef = [- defMethod "trivial" $ \m -> expectAction m $ \a -> case a of- SMTrivial -> return $ Right ()- _ -> return $ Left TBadActionCtor,+ defMethod "trivial" $ \m -> checkAction m SMTrivial retVoid, defMethod "ternary" $ \m v1 v2 v3 -> expectAction m $ \a -> case a of SMTernary w1 w2 w3 w4 -> (fmap . fmap) (const w4) $ checkArg (v1,v2,v3) (w1,w2,w3)@@ -107,33 +94,15 @@ defMethod "getInt" $ \m -> expectAction m $ \a -> case a of SMGetInt v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setInt" $ \m v -> expectAction m $ \a -> case a of- SMSetInt w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setInt" $ \m v -> checkAction m (SMSetInt v) retVoid, defMethod "getDouble" $ \m -> expectAction m $ \a -> case a of SMGetDouble v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setDouble" $ \m v -> expectAction m $ \a -> case a of- SMSetDouble w -> checkArg v w- _ -> return $ Left TBadActionCtor,- defMethod "getString" $ \m -> expectAction m $ \a -> case a of- SMGetString v -> return $ Right v- _ -> return $ Left TBadActionCtor,- defMethod "setString" $ \m v -> expectAction m $ \a -> case a of- SMSetString w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setDouble" $ \m v -> checkAction m (SMSetDouble v) retVoid, defMethod "getText" $ \m -> expectAction m $ \a -> case a of SMGetText v -> return $ Right v _ -> return $ Left TBadActionCtor,- defMethod "setText" $ \m v -> expectAction m $ \a -> case a of- SMSetText w -> checkArg v w- _ -> return $ Left TBadActionCtor,- defMethod "getURI" $ \m -> expectAction m $ \a -> case a of- SMGetURI v -> return $ Right v- _ -> return $ Left TBadActionCtor,- defMethod "setURI" $ \m v -> expectAction m $ \a -> case a of- SMSetURI w -> checkArg v w- _ -> return $ Left TBadActionCtor,+ defMethod "setText" $ \m v -> checkAction m (SMSetText v) retVoid, defMethod "getObject" $ \m -> expectAction m $ \a -> case a of SMGetObject _ -> getTestObject m _ -> return $ Left TBadActionCtor,@@ -142,57 +111,52 @@ _ -> return $ Left TBadActionCtor] data SimpleProperties- = SPGetIntRO Int32+ = SPGetIntConst Int32+ | SPGetIntRO Int32 | SPGetInt Int32 | SPSetInt Int32 | SPGetDouble Double | SPSetDouble Double- | SPGetString String- | SPSetString String | SPGetText Text | SPSetText Text- | SPGetURI URI- | SPSetURI URI | SPGetObject Int | SPSetObject Int- deriving (Show, Typeable)+ deriving (Eq, Show, Typeable) instance TestAction SimpleProperties where legalActionIn (SPSetObject n) env = testEnvIsaJ n testObjectType env legalActionIn _ _ = True nextActionsFor env = mayOneof [+ SPGetIntConst <$> fromGen arbitrary, SPGetIntRO <$> fromGen arbitrary, SPGetInt <$> fromGen arbitrary, SPSetInt <$> fromGen arbitrary, SPGetDouble <$> fromGen arbitrary, SPSetDouble <$> fromGen arbitrary,- SPGetString <$> fromGen arbitrary,- SPSetString <$> fromGen arbitrary, SPGetText . T.pack <$> fromGen arbitrary, SPSetText . T.pack <$> fromGen arbitrary,- SPGetURI <$> fromGen uriGen,- SPSetURI <$> fromGen uriGen, pure . SPGetObject $ testEnvNextJ env, SPSetObject <$> mayElements (testEnvListJ testObjectType env)] updateEnvRaw (SPGetObject n) = testEnvStep . testEnvSerial (\s -> testEnvSetJ n testObjectType s) updateEnvRaw _ = testEnvStep+ actionRemote (SPGetIntConst v) n = testProp n "propIntConst" $ S.literal v actionRemote (SPGetIntRO v) n = testProp n "propIntRO" $ S.literal v actionRemote (SPGetInt v) n = testProp n "propIntR" $ S.literal v actionRemote (SPSetInt v) n = setProp n "propIntW" $ S.literal v actionRemote (SPGetDouble v) n = testProp n "propDoubleR" $ S.literal v actionRemote (SPSetDouble v) n = setProp n "propDoubleW" $ S.literal v- actionRemote (SPGetString v) n = testProp n "propStringR" $ S.literal v- actionRemote (SPSetString v) n = setProp n "propStringW" $ S.literal v actionRemote (SPGetText v) n = testProp n "propTextR" $ S.literal v actionRemote (SPSetText v) n = setProp n "propTextW" $ S.literal v- actionRemote (SPGetURI v) n = testProp n "propURIR" $ S.literal v- actionRemote (SPSetURI v) n = setProp n "propURIW" $ S.literal v actionRemote (SPGetObject v) n = saveProp v n "propObjectR" 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+ _ -> return $ Left TBadActionCtor), defPropertyRO "propIntRO" (\m -> expectAction m $ \a -> case a of SPGetIntRO v -> return $ Right v@@ -203,50 +167,21 @@ _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propIntW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetInt w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetInt v) retVoid), defPropertyRW "propDoubleR" (\m -> expectAction m $ \a -> case a of SPGetDouble v -> return $ Right v _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propDoubleW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetDouble w -> checkArg v w- _ -> return $ Left TBadActionCtor),- defPropertyRW "propStringR"- (\m -> expectAction m $ \a -> case a of- SPGetString v -> return $ Right v- _ -> return $ Left TBadActionCtor)- (\m _ -> badAction m),- defPropertyRW "propStringW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetString w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetDouble v) retVoid), defPropertyRW "propTextR" (\m -> expectAction m $ \a -> case a of SPGetText v -> return $ Right v _ -> return $ Left TBadActionCtor) (\m _ -> badAction m), defPropertyRW "propTextW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetText w -> checkArg v w- _ -> return $ Left TBadActionCtor),- defPropertyRW "propURIR"- (\m -> expectAction m $ \a -> case a of- SPGetURI v -> return $ Right v- _ -> return $ Left TBadActionCtor)- (\m _ -> badAction m),- defPropertyRW "propURIW"- (\_ -> makeDef)- (\m v -> expectAction m $ \a -> case a of- SPSetURI w -> checkArg v w- _ -> return $ Left TBadActionCtor),+ (\_ -> makeDef) (\m v -> checkAction m (SPSetText v) retVoid), defPropertyRW "propObjectR" (\m -> expectAction m $ \a -> case a of SPGetObject _ -> getTestObject m
test/Test1.hs view
@@ -4,19 +4,43 @@ import Graphics.QML.Test.Framework import Graphics.QML.Test.Harness+import Graphics.QML.Test.DataTest 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 +import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import Test.QuickCheck.Arbitrary++instance Arbitrary Text where+ arbitrary = fmap T.pack $ arbitrary+ shrink = map T.pack . shrink . T.unpack+ main :: IO () main = do rs <- sequence [- checkProperty $ TestType (Proxy :: Proxy SimpleMethods),- checkProperty $ TestType (Proxy :: Proxy SimpleProperties),- checkProperty $ TestType (Proxy :: Proxy SignalTest1),- checkProperty $ TestType (Proxy :: Proxy ObjectA)]+ checkProperty 100 $ TestType (Proxy :: Proxy SimpleMethods),+ checkProperty 100 $ TestType (Proxy :: Proxy SimpleProperties),+ checkProperty 100 $ TestType (Proxy :: Proxy SignalTest1),+ checkProperty 100 $ TestType (Proxy :: Proxy ObjectA),+ 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 (Maybe Bool))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Int32))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Double))),+ checkProperty 20 $ TestType (Proxy :: Proxy (DataTest (Maybe Text))),+ 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 100 $ TestType (Proxy :: Proxy AutoListTest)] if and rs then exitSuccess else exitFailure