diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +# HsQML + +[![Tests](https://github.com/prolic/HsQML/workflows/Tests/badge.svg)](https://github.com/prolic/HsQML/actions?query=workflow%3ATests) +[![Build status](https://ci.appveyor.com/api/projects/status/github/prolic/HsQML?svg=true)](https://ci.appveyor.com/project/prolic/hsqml) + +HsQML is a Haskell binding to Qt Quick, a cross-platform framework for creating +graphical user interfaces. For further information on installing and using it, +please see the project's web site. + +**Home Page:** http://www.gekkou.co.uk/software/hsqml/ +**Original Darcs Repository (outdated):** http://hub.darcs.net/komadori/HsQML + +## Notes +- I made some changes, so this library works on newer GHC / cabal versions and has been tested on Qt5. +- This library has been tested with cabal 3.10.3.0, due to its custom Setup.hs, not all versions of cabal are supported. +- **Current Status:** This is a maintained fork of the original HsQML project. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,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' diff --git a/cbits/Canvas.cpp b/cbits/Canvas.cpp new file mode 100644 --- /dev/null +++ b/cbits/Canvas.cpp @@ -0,0 +1,863 @@ +#include "Canvas.h" +#include "Engine.h" +#include "Manager.h" + +#include +#include +#include +#include +#include + +HsQMLGLCallbacks::HsQMLGLCallbacks( + HsQMLGLSetupCb setupCb, HsQMLGLCleanupCb cleanupCb, + HsQMLGLSyncCb syncCb, HsQMLGLPaintCb paintCb) + : mSetupCb(setupCb) + , mCleanupCb(cleanupCb) + , mSyncCb(syncCb) + , mPaintCb(paintCb) +{} + +HsQMLGLCallbacks::~HsQMLGLCallbacks() +{ + gManager->freeFun(reinterpret_cast(mSyncCb)); + gManager->freeFun(reinterpret_cast(mPaintCb)); +} + +HsQMLGLDelegateImpl::HsQMLGLDelegateImpl(HsQMLGLMakeCallbacksCb makeContextCb) + : mMakeCallbacksCb(makeContextCb) +{} + +HsQMLGLDelegateImpl::~HsQMLGLDelegateImpl() +{ + gManager->freeFun(reinterpret_cast(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(); + 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( + mGL->getProcAddress("glViewport")); + mGLClearColorFn = reinterpret_cast( + mGL->getProcAddress("glClearColor")); + mGLClearFn = reinterpret_cast( + 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(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().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(&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(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(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(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( + mContextType)); + } + if (mContextProfile >= 0) { + fmt.setProfile(static_cast( + 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(new HsQMLGLDelegate()); +} + +void hsqml_finalise_gldelegate_handle( + HsQMLGLDelegateHandle* hndl) +{ + HsQMLGLDelegate* delegate = reinterpret_cast(hndl); + delete delegate; +} + +void hsqml_gldelegate_setup( + HsQMLGLDelegateHandle* hndl, + HsQMLGLMakeCallbacksCb makeContextCb) +{ + HsQMLGLDelegate* delegate = reinterpret_cast(hndl); + delegate->setup(makeContextCb); +} + +void hsqml_gldelegate_to_jval( + HsQMLGLDelegateHandle* hndl, + HsQMLJValHandle* jhndl) +{ + HsQMLGLDelegate* delegate = reinterpret_cast(hndl); + new((void*)jhndl) QJSValue( + gManager->activeEngine()->declEngine()->toScriptValue(*delegate)); +} + +int hsqml_gldelegate_from_jval( + HsQMLGLDelegateHandle* hndl, + HsQMLJValHandle* jhndl) +{ + HsQMLGLDelegate* delegate = reinterpret_cast(hndl); + QJSValue* value = reinterpret_cast(jhndl); + *delegate = gManager->activeEngine()->declEngine()-> + fromScriptValue(*value); + return delegate->isValid(); +} diff --git a/cbits/Canvas.h b/cbits/Canvas.h new file mode 100644 --- /dev/null +++ b/cbits/Canvas.h @@ -0,0 +1,295 @@ +#ifndef HSQML_CANVAS_H +#define HSQML_CANVAS_H + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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 CallbacksRef; + CallbacksRef makeCallbacks(); + +private: + QExplicitlySharedDataPointer 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 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 mFBO; + QScopedPointer 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 diff --git a/cbits/Class.cpp b/cbits/Class.cpp new file mode 100644 --- /dev/null +++ b/cbits/Class.cpp @@ -0,0 +1,178 @@ +#include +#include +#include +#include +#include +#include + +#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 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(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; ifreeFun((HsFunPtr)mMethods[i]); + mMethods[i] = NULL; + } + for (unsigned int i=0; i<2*mPropertyCount; i++) { + if (mProperties[i]) { + gManager->freeFun((HsFunPtr)mProperties[i]); + mProperties[i] = NULL; + } + } + gManager->freeStable(mHsTypeRep); + mHsTypeRep = NULL; + std::free(mMetaData); + mMetaData = NULL; + std::free(mMethods); + mMethods = NULL; + std::free(mProperties); + mProperties = NULL; + + gManager->updateCounter(HsQMLManager::ClassCount, -1); + + // Qt internally retains pointers to QMetaObjects it has encountered + // without any mechanism for unregistering them. Hence, classes can't be + // deleted prior to shutdown. + gManager->zombifyClass(this); +} + +extern "C" int hsqml_get_next_class_id() +{ + 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); +} diff --git a/cbits/Class.h b/cbits/Class.h new file mode 100644 --- /dev/null +++ b/cbits/Class.h @@ -0,0 +1,41 @@ +#ifndef HSQML_CLASS_H +#define HSQML_CLASS_H + +#include +#include +#include + +#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 mMetaStrData; + HsStablePtr mHsTypeRep; + int mMethodCount; + int mPropertyCount; + HsQMLUniformFunc* mMethods; + HsQMLUniformFunc* mProperties; + QMetaObject mMetaObject; +}; + +#endif /*HSQML_CLASS_H*/ diff --git a/cbits/ClipboardHelper.cpp b/cbits/ClipboardHelper.cpp new file mode 100644 --- /dev/null +++ b/cbits/ClipboardHelper.cpp @@ -0,0 +1,9 @@ +#include "ClipboardHelper.h" + +HsQMLClipboardHelper::HsQMLClipboardHelper(QObject *parent) + : QObject(parent) {} + +void HsQMLClipboardHelper::copyText(const QString &text) { + QClipboard *clipboard = QGuiApplication::clipboard(); + clipboard->setText(text); +} diff --git a/cbits/ClipboardHelper.h b/cbits/ClipboardHelper.h new file mode 100644 --- /dev/null +++ b/cbits/ClipboardHelper.h @@ -0,0 +1,16 @@ +#ifndef CLIPBOARDHELPER_H +#define CLIPBOARDHELPER_H + +#include +#include +#include + +class HsQMLClipboardHelper : public QObject { + Q_OBJECT +public: + explicit HsQMLClipboardHelper(QObject *parent = nullptr); + + Q_INVOKABLE void copyText(const QString &text); +}; + +#endif // CLIPBOARDHELPER_H diff --git a/cbits/Engine.cpp b/cbits/Engine.cpp new file mode 100644 --- /dev/null +++ b/cbits/Engine.cpp @@ -0,0 +1,241 @@ +#include +#include + +#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(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(obj); + QQuickItem* item = qobject_cast(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 errs = mComponent.errors(); + for (QList::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(contextObject); + config->initialURL = *reinterpret_cast(initialURL); + for (QString** p = reinterpret_cast(importPaths); *p; p++) { + config->importPaths.push_back(**p); + } + for (QString** p = reinterpret_cast(pluginPaths); *p; p++) { + config->pluginPaths.push_back(**p); + } + config->stopCb = stopCb; + + gManager->postAppEvent(config); + return reinterpret_cast(proxy); +} + +extern "C" void hsqml_kill_engine( + HsQMLEngineHandle* hndl) +{ + HsQMLEngineProxy* proxy = reinterpret_cast(hndl); + + Q_ASSERT(gManager->isEventThread()); + proxy->kill(); +} + +extern void hsqml_finalise_engine_handle( + HsQMLEngineHandle* hndl) +{ + HsQMLEngineProxy* proxy = (HsQMLEngineProxy*)hndl; + proxy->deref(HsQMLEngineProxy::Handle); +} diff --git a/cbits/Engine.h b/cbits/Engine.h new file mode 100644 --- /dev/null +++ b/cbits/Engine.h @@ -0,0 +1,81 @@ +#ifndef HSQML_ENGINE_H +#define HSQML_ENGINE_H + +#include +#include +#include +#include +#include +#include +#include + +#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 mGlobals; + QList mResources; + HsQMLTrivialCb mStopCb; +}; + +#endif /*HSQML_ENGINE_H*/ diff --git a/cbits/HighDpiScaling.cpp b/cbits/HighDpiScaling.cpp new file mode 100644 --- /dev/null +++ b/cbits/HighDpiScaling.cpp @@ -0,0 +1,5 @@ +#include "QtGui/QGuiApplication" + +extern "C" void hsqml_enable_high_dpi_scaling() { + QGuiApplication::setAttribute(Qt::AA_EnableHighDpiScaling); +} diff --git a/cbits/HighDpiScaling.h b/cbits/HighDpiScaling.h new file mode 100644 --- /dev/null +++ b/cbits/HighDpiScaling.h @@ -0,0 +1,9 @@ +#ifdef __cplusplus +extern "C" { +#endif + +void hsqml_enable_high_dpi_scaling(); + +#ifdef __cplusplus +} +#endif diff --git a/cbits/HsQMLClass.cpp b/cbits/HsQMLClass.cpp deleted file mode 100644 --- a/cbits/HsQMLClass.cpp +++ /dev/null @@ -1,146 +0,0 @@ -#include -#include -#include -#include -#include - -#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; ifreeFun((HsFunPtr)mMethods[i]); - } - for (unsigned int i=0; i<2*mPropertyCount; i++) { - if (mProperties[i]) { - gManager->freeFun((HsFunPtr)mProperties[i]); - } - } - gManager->freeStable(mHsTypeRep); - std::free(mMetaData); - std::free(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); -} diff --git a/cbits/HsQMLClass.h b/cbits/HsQMLClass.h deleted file mode 100644 --- a/cbits/HsQMLClass.h +++ /dev/null @@ -1,39 +0,0 @@ -#ifndef HSQML_CLASS_H -#define HSQML_CLASS_H - -#include -#include - -#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*/ diff --git a/cbits/HsQMLEngine.cpp b/cbits/HsQMLEngine.cpp deleted file mode 100644 --- a/cbits/HsQMLEngine.cpp +++ /dev/null @@ -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(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(contextObject); - config.initialURL = *reinterpret_cast(initialURL); - config.showWindow = static_cast(showWindow); - if (setWindowTitle) { - config.setWindowTitle = true; - config.windowTitle = *reinterpret_cast(windowTitle); - } - config.stopCb = stopCb; - - Q_ASSERT (gManager); - gManager->createEngine(config); -} diff --git a/cbits/HsQMLEngine.h b/cbits/HsQMLEngine.h deleted file mode 100644 --- a/cbits/HsQMLEngine.h +++ /dev/null @@ -1,68 +0,0 @@ -#ifndef HSQML_ENGINE_H -#define HSQML_ENGINE_H - -#include -#include -#include -#include -#include -#include -#include - -#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 mContextObj; - HsQMLTrivialCb mStopCb; -}; - -#endif /*HSQML_ENGINE_H*/ diff --git a/cbits/HsQMLIntrinsics.cpp b/cbits/HsQMLIntrinsics.cpp deleted file mode 100644 --- a/cbits/HsQMLIntrinsics.cpp +++ /dev/null @@ -1,77 +0,0 @@ -#include -#include - -#include -#include - -#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(string->data()); -} - -extern "C" int hsqml_unmarshal_string( - HsQMLStringHandle* hndl, UTF16** bufPtr) -{ - QString* string = (QString*)hndl; - *bufPtr = reinterpret_cast(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(malloc(bufLen)); - memcpy(buf, cstr.data(), bufLen); - *bufPtr = buf; - return bufLen; -} diff --git a/cbits/HsQMLManager.cpp b/cbits/HsQMLManager.cpp deleted file mode 100644 --- a/cbits/HsQMLManager.cpp +++ /dev/null @@ -1,325 +0,0 @@ -#include -#include -#include -#include -#include -#include -#ifdef Q_WS_MAC -#include -#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; ilog(QString().sprintf("%s = %d.", - cCounterNames[i], gManager->updateCounter( - static_cast(i), 0))); - } - } -} - -QAtomicPointer 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"); - - 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(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); -} diff --git a/cbits/HsQMLManager.h b/cbits/HsQMLManager.h deleted file mode 100644 --- a/cbits/HsQMLManager.h +++ /dev/null @@ -1,109 +0,0 @@ -#ifndef HSQML_MANAGER_H -#define HSQML_MANAGER_H - -#include -#include -#include -#include -#include - -#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::User+StartedLoopEventIndex); - static const QEvent::Type StopLoopEvent = - static_cast(QEvent::User+StopLoopEventIndex); - static const QEvent::Type PendingJobsEvent = - static_cast(QEvent::User+PendingJobsEventIndex); - static const QEvent::Type RemoveGCLockEvent = - static_cast(QEvent::User+RemoveGCLockEventIndex); - -private: - Q_DISABLE_COPY(HsQMLManagerApp) - - int mArgC; - char mArg0; - char* mArgV; - QApplication mApp; -}; - -extern QAtomicPointer gManager; - -#endif /*HSQML_MANAGER_H*/ diff --git a/cbits/HsQMLObject.cpp b/cbits/HsQMLObject.cpp deleted file mode 100644 --- a/cbits/HsQMLObject.cpp +++ /dev/null @@ -1,329 +0,0 @@ -#include -#include -#include - -#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(const_cast(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); - } -} diff --git a/cbits/HsQMLObject.h b/cbits/HsQMLObject.h deleted file mode 100644 --- a/cbits/HsQMLObject.h +++ /dev/null @@ -1,71 +0,0 @@ -#ifndef HSQML_OBJECT_H -#define HSQML_OBJECT_H - -#include -#include -#include -#include - -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*/ diff --git a/cbits/HsQMLWindow.cpp b/cbits/HsQMLWindow.cpp deleted file mode 100644 --- a/cbits/HsQMLWindow.cpp +++ /dev/null @@ -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(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(); -} diff --git a/cbits/HsQMLWindow.h b/cbits/HsQMLWindow.h deleted file mode 100644 --- a/cbits/HsQMLWindow.h +++ /dev/null @@ -1,45 +0,0 @@ -#ifndef HSQML_WINDOW_H -#define HSQML_WINDOW_H - -#include -#include -#include -#include -#include -#include - -#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*/ diff --git a/cbits/Intrinsics.cpp b/cbits/Intrinsics.cpp new file mode 100644 --- /dev/null +++ b/cbits/Intrinsics.cpp @@ -0,0 +1,171 @@ +#include +#include +#include + +#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(hndl); + string->~QString(); +} + +extern "C" UTF16* hsqml_write_string( + int bufLen, HsQMLStringHandle* hndl) +{ + QString* string = reinterpret_cast(hndl); + string->resize(bufLen); + return reinterpret_cast(string->data()); +} + +extern "C" int hsqml_read_string( + HsQMLStringHandle* hndl, UTF16** bufPtr) +{ + QString* string = reinterpret_cast(hndl); + *bufPtr = reinterpret_cast(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(); +} + +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(hndl); + QJSValue* srcValue = reinterpret_cast(srch); + *dstValue = *srcValue; +} + +extern "C" void hsqml_deinit_jval(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(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(hndl); + return value->isBool(); +} + +extern "C" int hsqml_get_jval_bool(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(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(hndl); + return value->isNumber(); +} + +extern "C" int hsqml_get_jval_int(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->toInt(); +} + +extern "C" double hsqml_get_jval_double(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->toNumber(); +} + +extern "C" void hsqml_init_jval_string( + HsQMLJValHandle* hndl, HsQMLStringHandle* strh) +{ + QString* string = reinterpret_cast(strh); + new((void*)hndl) QJSValue(*string); +} +extern "C" int hsqml_is_jval_string(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->isString(); +} + +extern "C" void hsqml_get_jval_string( + HsQMLJValHandle* hndl, HsQMLStringHandle* strh) +{ + QJSValue* value = reinterpret_cast(hndl); + QString* string = reinterpret_cast(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(hndl); + return value->isArray(); +} + +extern "C" unsigned int hsqml_get_jval_array_length(HsQMLJValHandle* hndl) +{ + QJSValue* value = reinterpret_cast(hndl); + return value->property("length").toUInt(); +} + +extern "C" void hsqml_jval_array_get( + HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl) +{ + QJSValue* array = reinterpret_cast(ahndl); + QJSValue* value = reinterpret_cast(hndl); + *value = array->property(i); +} + +extern "C" void hsqml_jval_array_set( + HsQMLJValHandle* ahndl, unsigned int i, HsQMLJValHandle* hndl) +{ + QJSValue* array = reinterpret_cast(ahndl); + QJSValue* value = reinterpret_cast(hndl); + array->setProperty(i, *value); +} diff --git a/cbits/Manager.cpp b/cbits/Manager.cpp new file mode 100644 --- /dev/null +++ b/cbits/Manager.cpp @@ -0,0 +1,632 @@ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#ifdef Q_OS_MAC +#include +#endif + +#include "Canvas.h" +#include "Class.h" +#include "ClipboardHelper.h" +#include "Engine.h" +#include "Manager.h" +#include "Model.h" +#include "Object.h" + +// Declarations for part of Qt's internal API +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; ilog(QString().sprintf("%s = %d.", + cCounterNames[i], gManager->updateCounter( + static_cast(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& 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(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(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(p); + if ((pp < &guard || pp > mStackBase) && p->type == QMetaType::QObjectStar) { + if (isEventThread() && mObjectSet.contains(p->data.o)) { + HsQMLObject* obj = static_cast(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("HsQML.Canvas", 1, 0, "HaskellCanvas"); + qmlRegisterType( + "HsQML.Canvas", 1, 0, "OpenGLContextControl"); + qmlRegisterType( + "HsQML.Model", 1, 0, "AutoListModel"); + qmlRegisterType( + "HsQML.Clipboard", 1, 0, "ClipboardHelper"); +} + +HsQMLManagerApp::~HsQMLManagerApp() +{ + qDeleteAll(gManager->mZombieClasses); + gManager->mZombieClasses.clear(); +} + +void HsQMLManagerApp::customEvent(QEvent* ev) +{ + 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(ev)->process(); + break;} + case HsQMLManagerApp::CreateEngineEvent: { + HsQMLEngineCreateEvent* create = + static_cast(ev); + if (create->proxy()->dead()) { + create->stopCb(); + } + else { + new HsQMLEngine(create, this); + } + break;} + default: break; + } +} + +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(args); *p; p++) { + argsList.push_back(**p); + } + return gManager->setArgs(argsList); +} + +extern "C" int hsqml_get_args_count() +{ + return gManager->argsPtrs().size(); +} + +extern "C" void hsqml_get_args(HsQMLStringHandle** args) +{ + int argc = gManager->argsPtrs().size(); + char** argv = gManager->argsPtrs().data(); + for (int i=0; i(args[i]); + *string = QString::fromLocal8Bit(argv[i]); + } +} + +extern "C" int hsqml_set_flag(HsQMLGlobalFlag flag, int value) +{ + return gManager->setFlag(flag, value); +} + +extern "C" int hsqml_get_flag(HsQMLGlobalFlag flag) +{ + return gManager->getFlag(flag); +} + +extern "C" HsQMLEventLoopStatus hsqml_evloop_run( + HsQMLTrivialCb startCb, + HsQMLTrivialCb jobsCb, + 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)); + } +} diff --git a/cbits/Manager.h b/cbits/Manager.h new file mode 100644 --- /dev/null +++ b/cbits/Manager.h @@ -0,0 +1,153 @@ +#ifndef HSQML_MANAGER_H +#define HSQML_MANAGER_H + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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& 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 mArgs; + QVector mArgsPtrs; + QSet mObjectSet; + QVector 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::User+StartedLoopEventIndex); + static const QEvent::Type StopLoopEvent = + static_cast(QEvent::User+StopLoopEventIndex); + static const QEvent::Type PendingJobsEvent = + static_cast(QEvent::User+PendingJobsEventIndex); + static const QEvent::Type RemoveGCLockEvent = + static_cast(QEvent::User+RemoveGCLockEventIndex); + static const QEvent::Type CreateEngineEvent = + static_cast(QEvent::User+CreateEngineEventIndex); + +private: + Q_DISABLE_COPY(HsQMLManagerApp) + + QVariant::Handler mHookedHandler; + int mArgC; + QApplication mApp; +}; + +class ManagerPointer : public QAtomicPointer +{ +public: + HsQMLManager* operator->() const + { + return load(); + } + + operator HsQMLManager*() const + { + return load(); + } +}; + +extern ManagerPointer gManager; + +#endif /*HSQML_MANAGER_H*/ diff --git a/cbits/Model.cpp b/cbits/Model.cpp new file mode 100644 --- /dev/null +++ b/cbits/Model.cpp @@ -0,0 +1,340 @@ +#include +#include + +#include "Model.h" +#include "Manager.h" + +HsQMLAutoListModel::HsQMLAutoListModel(QObject* parent) + : QAbstractListModel(parent) + , mMode(ByReset) + , mEqualityTestValid(false) + , mKeyFunctionValid(false) + , mOldOffset(0) + , mDefer(false) + , mPending(false) +{ +} + +void HsQMLAutoListModel::classBegin() +{ + mDefer = true; +} + +void HsQMLAutoListModel::componentComplete() +{ + mDefer = false; + if (mPending) { + updateModel(); + } +} + +int HsQMLAutoListModel::rowCount(const QModelIndex&) const +{ + return fromOldIndex(mOldModel.size()); +} + +QVariant HsQMLAutoListModel::data(const QModelIndex& index, int) const +{ + int i = index.row(); + const Element& e = + i < mNewModel.size() ? mNewModel[i] : mOldModel[toOldIndex(i)]; + return e.mValue.toVariant(); +} + +QHash HsQMLAutoListModel::roleNames() const +{ + QHash roleNames; + roleNames.insert(Qt::UserRole, QByteArray("modelData")); + return roleNames; +} + +void HsQMLAutoListModel::setMode(Mode mode) +{ + mMode = mode; +} + +HsQMLAutoListModel::Mode HsQMLAutoListModel::mode() const +{ + return mMode; +} + +void HsQMLAutoListModel::setSource(const QJSValue& source) +{ + bool change = !mSource.strictlyEquals(source); + mSource = source; + if (change) { + sourceChanged(); + } + updateModel(); +} + +QJSValue HsQMLAutoListModel::source() const +{ + return mSource; +} + +void HsQMLAutoListModel::setEqualityTest(const QJSValue& equalityTest) +{ + mEqualityTest = equalityTest; + mEqualityTestValid = equalityTest.isCallable(); +} + +QJSValue HsQMLAutoListModel::equalityTest() const +{ + return mEqualityTest; +} + +void HsQMLAutoListModel::setKeyFunction(const QJSValue& keyFunction) +{ + mKeyFunction = keyFunction; + mKeyFunctionValid = keyFunction.isCallable(); + mRehash = true; +} + +QJSValue HsQMLAutoListModel::keyFunction() const +{ + return mKeyFunction; +} + +void HsQMLAutoListModel::updateModel() +{ + if (mDefer) { + mPending = true; + return; + } + + switch (mMode) { + case ByReset: + updateModelByReset(); break; + case ByIndex: + updateModelByIndex(); break; + case ByKey: + updateModelByKey(true); break; + case ByKeyNoReorder: + updateModelByKey(false); break; + } +} + +void HsQMLAutoListModel::updateModelByReset() +{ + int srcLen = sourceLength(); + + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByReset: Inserted %d elements.", srcLen)); + beginResetModel(); + mOldModel.clear(); + mOldModel.reserve(srcLen); + for (int i=0; i oldLen) { + mOldModel.reserve(srcLen); + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByIndex: Inserted %d extra elements at %d.", + srcLen - oldLen, oldLen)); + beginInsertRows(QModelIndex(), oldLen, srcLen-1); + for (int i=oldLen; i srcLen) { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByIndex: Removed %d excess elements at %d.", + oldLen - srcLen, srcLen)); + beginRemoveRows(QModelIndex(), srcLen, oldLen-1); + mOldModel.erase(mOldModel.begin()+srcLen, mOldModel.end()); + endRemoveRows(); + } + + // This mode doesn't maintain the hashes + mRehash = true; +} + +void HsQMLAutoListModel::updateModelByKey(bool reorder) +{ + int srcLen = sourceLength(); + + // Build a map of element key's highest indices in the new source + typedef QHash SrcDict; + SrcDict srcDict; + if (reorder) { + for (int i=0; i ModelDict; + ModelDict modelDict; + for (int idx = mOldModel.size()-1; idx >= 0; --idx) { + Element& e = mOldModel[idx]; + if (mRehash) { + e.mKey = keyFunction(e.mValue); + } + modelDict.insert(e.mKey, idx); + } + mRehash = false; + + // Rearrange and insert new elements + Q_ASSERT(!mNewModel.size() && !mOldOffset); + mNewModel.reserve(srcLen); + for (int i=0; i= mOldOffset); + Q_ASSERT(elemIdx < mOldModel.size()); + modelDict.erase(it); + + // Try removing elements before target + while (elemIdx > mOldOffset) { + const Element& nextElem = mOldModel[mOldOffset]; + + if (reorder) { + // Check if element will be used later + SrcDict::iterator srcIt = srcDict.find(nextElem.mKey); + if (srcIt != srcDict.end()) { + if (srcIt.value() >= i) { + // Old element is still needed by the new source + break; + } + } + } + + // Remove element + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Removed element at %d.", i)); + beginRemoveRows(QModelIndex(), i, i); + mOldOffset++; + endRemoveRows(); + modelDict.erase(modelDict.find(nextElem.mKey)); + } + + // Move target element earlier in list if needed + if (elemIdx > mOldOffset) { + Q_ASSERT(reorder); + int srcIdx = fromOldIndex(elemIdx); + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Moved element at %d to %d.", + srcIdx, i)); + beginMoveRows(QModelIndex(), srcIdx, srcIdx, QModelIndex(), i); + mNewModel.append(mOldModel[elemIdx]); + mOldModel.remove(elemIdx); + endMoveRows(); + + // Renumber remaining indices in the old model + for (ModelDict::iterator renumIt = modelDict.begin(); + renumIt != modelDict.end();) { + ModelDict::iterator currIt = renumIt++; + Q_ASSERT(currIt.value() >= mOldOffset); + if (currIt.value() > elemIdx) { + currIt.value()--; + } + } + } + else { + // Transfer element from old to new model + mNewModel.append(mOldModel[elemIdx]); + mOldOffset++; + } + + // Has value changed? + handleInequality(srcVal, mNewModel, i); + Q_ASSERT(mNewModel.size() == i+1); + } + else { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Inserted element at %d.", i)); + beginInsertRows(QModelIndex(), i, i); + mNewModel.append(Element(srcVal, srcKey)); + endInsertRows(); + } + } + + // Move element to the old model, removing any excess elements from the end + bool excess = mOldOffset < mOldModel.size(); + if (excess) { + HSQML_LOG(3, QString().sprintf( + "AutoListModel.ByKey: Removed %d excess elements at %d.", + mOldModel.size() - mOldOffset, srcLen)); + beginRemoveRows(QModelIndex(), srcLen, rowCount(QModelIndex())-1); + } + mNewModel.swap(mOldModel); + mNewModel.clear(); + mOldOffset = 0; + if (excess) { + endRemoveRows(); + } +} + +int HsQMLAutoListModel::sourceLength() +{ + return mSource.property("length").toInt(); +} + +int HsQMLAutoListModel::toOldIndex(int i) const +{ + return i - mNewModel.size() + mOldOffset; +} + +int HsQMLAutoListModel::fromOldIndex(int i) const +{ + return i + mNewModel.size() - mOldOffset; +} + +void HsQMLAutoListModel::handleInequality( + const QJSValue& a, Model& model, int i) +{ + if (!equalityTest(a, model[i].mValue)) { + model[i].mValue = a; + QModelIndex idx = createIndex(i, 0); + dataChanged(idx, idx); + } +} + +bool HsQMLAutoListModel::equalityTest(const QJSValue& a, const QJSValue& b) +{ + if (mEqualityTestValid) { + QJSValueList args; + args.append(a); + args.append(b); + return mEqualityTest.call(args).toBool(); + } + else { + return a.equals(b); + } +} + +QString HsQMLAutoListModel::keyFunction(const QJSValue& a) +{ + if (mKeyFunctionValid) { + QJSValueList args; + args.append(a); + return mKeyFunction.call(args).toString(); + } + else { + return a.toString(); + } +} diff --git a/cbits/Model.h b/cbits/Model.h new file mode 100644 --- /dev/null +++ b/cbits/Model.h @@ -0,0 +1,85 @@ +#ifndef HSQML_MODEL_H +#define HSQML_MODEL_H + +#include +#include +#include +#include + +class HsQMLAutoListModel : public QAbstractListModel, public QQmlParserStatus +{ + Q_OBJECT + Q_INTERFACES(QQmlParserStatus) + Q_ENUMS(Mode) + Q_PROPERTY(Mode mode READ mode WRITE setMode) + Q_PROPERTY(QJSValue source READ source WRITE setSource NOTIFY sourceChanged) + Q_PROPERTY(QJSValue equalityTest READ equalityTest WRITE setEqualityTest) + Q_PROPERTY(QJSValue keyFunction READ keyFunction WRITE setKeyFunction) + +public: + enum Mode { + ByReset, + ByIndex, + ByKey, + ByKeyNoReorder + }; + + HsQMLAutoListModel(QObject* = NULL); + + int rowCount(const QModelIndex&) const; + QVariant data(const QModelIndex&, int) const; + QHash roleNames() const; + + Q_SIGNAL void sourceChanged(); + void classBegin(); + void componentComplete(); + void setMode(Mode); + Mode mode() const; + void setSource(const QJSValue&); + QJSValue source() const; + void setEqualityTest(const QJSValue&); + QJSValue equalityTest() const; + void setKeyFunction(const QJSValue&); + QJSValue keyFunction() const; + +private: + struct Element { + Element() {} + Element(const QJSValue& value) : mValue(value) {} + Element(const QJSValue& value, const QString& key) + : mValue(value), mKey(key) {} + QJSValue mValue; + QString mKey; + }; + typedef QVector Model; + + void updateModel(); + void updateModelByReset(); + void updateModelByIndex(); + void updateModelByKey(bool); + int sourceLength(); + int toOldIndex(int) const; + int fromOldIndex(int) const; + bool modeTest(const QJSValue&, const QString&, int, int); + void handleInequality(const QJSValue&, Model&, int); + bool equalityTest(const QJSValue&, const QJSValue&); + bool identityTest(const QJSValue&, const QJSValue&); + QString keyFunction(const QJSValue&); + + Mode mMode; + QJSValue mSource; + QJSValue mEqualityTest; + bool mEqualityTestValid; + QJSValue mIdentityTest; + bool mIdentityTestValid; + QJSValue mKeyFunction; + bool mKeyFunctionValid; + Model mOldModel; + Model mNewModel; + int mOldOffset; + bool mDefer; + bool mPending; + bool mRehash; +}; + +#endif //HSQML_MODEL_H diff --git a/cbits/Object.cpp b/cbits/Object.cpp new file mode 100644 --- /dev/null +++ b/cbits/Object.cpp @@ -0,0 +1,463 @@ +#include +#include +#include +#include + +#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(mFinaliseCb)); +} + +void HsQMLObjectFinaliser::finalise(HsQMLObjectProxy* proxy) const +{ + mFinaliseCb(reinterpret_cast(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(const_cast(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(hndl); + return (void*)proxy->object(gManager->activeEngine()); +} + +extern HsQMLJValHandle* hsqml_object_get_jval( + HsQMLObjectHandle* hndl) +{ + HsQMLObjectProxy* proxy = reinterpret_cast(hndl); + HsQMLObject* obj = proxy->object(gManager->activeEngine()); + return reinterpret_cast(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(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( + new HsQMLObjectFinaliser::Ref(new HsQMLObjectFinaliser(cb))); +} + +extern void hsqml_finalise_obj_finaliser( + HsQMLObjFinaliserHandle* hndl) +{ + HsQMLObjectFinaliser::Ref* fp = + reinterpret_cast(hndl); + delete fp; +} + +extern void hsqml_object_add_finaliser( + HsQMLObjectHandle* hndl, HsQMLObjFinaliserHandle* fhndl) +{ + HsQMLObjectProxy* proxy = reinterpret_cast(hndl); + proxy->addFinaliser(*reinterpret_cast(fhndl)); +} diff --git a/cbits/Object.h b/cbits/Object.h new file mode 100644 --- /dev/null +++ b/cbits/Object.h @@ -0,0 +1,102 @@ +#ifndef HSQML_OBJECT_H +#define HSQML_OBJECT_H + +#include +#include +#include +#include +#include +#include +#include + +#include "hsqml.h" + +class HsQMLEngine; +class HsQMLClass; +class HsQMLObject; +class HsQMLObjectProxy; + +class HsQMLObjectFinaliser : public QSharedData +{ +public: + typedef QExplicitlySharedDataPointer 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 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*/ diff --git a/cbits/hsqml.h b/cbits/hsqml.h --- a/cbits/hsqml.h +++ b/cbits/hsqml.h @@ -8,19 +8,18 @@ #include #include -/* 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 } diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -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/ diff --git a/src/Graphics/QML.hs b/src/Graphics/QML.hs --- a/src/Graphics/QML.hs +++ b/src/Graphics/QML.hs @@ -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 diff --git a/src/Graphics/QML/Canvas.hs b/src/Graphics/QML/Canvas.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Canvas.hs @@ -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 diff --git a/src/Graphics/QML/Debug.hs b/src/Graphics/QML/Debug.hs --- a/src/Graphics/QML/Debug.hs +++ b/src/Graphics/QML/Debug.hs @@ -8,4 +8,6 @@ -- | Sets the global debug log level. At level zero, no logging information -- will be printed. Higher levels will increase debug verbosity. setDebugLogLevel :: Int -> IO () -setDebugLogLevel = hsqmlSetDebugLoglevel +setDebugLogLevel lvl = do + hsqmlInit + hsqmlSetDebugLoglevel lvl diff --git a/src/Graphics/QML/Engine.hs b/src/Graphics/QML/Engine.hs --- a/src/Graphics/QML/Engine.hs +++ b/src/Graphics/QML/Engine.hs @@ -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 diff --git a/src/Graphics/QML/Internal/BindCanvas.chs b/src/Graphics/QML/Internal/BindCanvas.chs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Internal/BindCanvas.chs @@ -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 #} diff --git a/src/Graphics/QML/Internal/BindCore.chs b/src/Graphics/QML/Internal/BindCore.chs --- a/src/Graphics/QML/Internal/BindCore.chs +++ b/src/Graphics/QML/Internal/BindCore.chs @@ -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 @@ -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 ^ diff --git a/src/Graphics/QML/Internal/BindObj.chs b/src/Graphics/QML/Internal/BindObj.chs --- a/src/Graphics/QML/Internal/BindObj.chs +++ b/src/Graphics/QML/Internal/BindObj.chs @@ -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'} -> + `()' #} + diff --git a/src/Graphics/QML/Internal/BindPrim.chs b/src/Graphics/QML/Internal/BindPrim.chs --- a/src/Graphics/QML/Internal/BindPrim.chs +++ b/src/Graphics/QML/Internal/BindPrim.chs @@ -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'} -> + `()' #} diff --git a/src/Graphics/QML/Internal/Marshal.hs b/src/Graphics/QML/Internal/Marshal.hs --- a/src/Graphics/QML/Internal/Marshal.hs +++ b/src/Graphics/QML/Internal/Marshal.hs @@ -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} diff --git a/src/Graphics/QML/Internal/MetaObj.hs b/src/Graphics/QML/Internal/MetaObj.hs --- a/src/Graphics/QML/Internal/MetaObj.hs +++ b/src/Graphics/QML/Internal/MetaObj.hs @@ -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 diff --git a/src/Graphics/QML/Internal/Objects.hs b/src/Graphics/QML/Internal/Objects.hs --- a/src/Graphics/QML/Internal/Objects.hs +++ b/src/Graphics/QML/Internal/Objects.hs @@ -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 diff --git a/src/Graphics/QML/Internal/Types.hs b/src/Graphics/QML/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Internal/Types.hs @@ -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 diff --git a/src/Graphics/QML/Marshal.hs b/src/Graphics/QML/Marshal.hs --- a/src/Graphics/QML/Marshal.hs +++ b/src/Graphics/QML/Marshal.hs @@ -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) diff --git a/src/Graphics/QML/Model.hs b/src/Graphics/QML/Model.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Model.hs @@ -0,0 +1,57 @@ +{-| Facility for working with Qt data models. + +This module is a placeholder for the ability to freely define QML classes which +implement the @QAbstractItemModel@ interface and functions to interact with +those models. This is not currently supported, but the functionality will be +available in a future release. + +HsQML does currently provide one mechanism for creating a Qt data model, the +@AutoListModel@ item. This item implements the @QAbstractItemModel@ interface +and provides a QML-side solution for generating a stateful Qt data model from a +succession of JavaScript arrays. + +The advantage of this over using the arrays directly is that, when the array +changes, the @AutoListModel@ can generate item add, remove, and change events +based on the differences between the old and new arrays. An simple array +binding, on the other hand, causes the entire model to be reset so that views +lose their state, cannot animate changes, etc. + +To use this facility, you must assign an @AutoListModel@ item to the @model@ +property of a QML view such as a @Repeater@ item. In turn, the @source@ +property of the @AutoListModel@ must then be bound to an expression yielding +the arrays you want to use. The @AutoListModel@ can be imported from the +@HsQML.Model 1.0@ module using an @import@ statement in your QML script and it +has several properties which can be set from QML as described below: + +[@mode@] Specifies how the model is updated when the source array changes. +Possible values are: + + [@AutoListModel.ByReset@] The model is reset entirely (default). + [@AutoListModel.ByIndex@] The elements in the old and new arrays are + compared for equality and change signals are sent for any that aren't + equal. If the length of the array has changed then elements will be added + to or removed from the end of the list model. + [@AutoListModel.ByKey@] The key function is applied to each element in the + old and new arrays. According to the key, elements which exist in both the + old and new arrays are moved to their new positions in the list model as + necessary, elements which only exist in the new array are added, and ones + which only existed in the old are removed. Where elements have been moved, + the old and new values are compared for equality and change signals are + sent for any that aren't equal. Unlike the other modes which only require + linear time to process the arrays, if elements are reordered then this mode + requires quadratic time in the worst case. + [@AutoListModel.ByKeyNoReorder@] This is the same as the ByKey mode except + that the model will not explicitly move elements to different positions, + only remove and re-add them at their new location as necessary. + +[@source@] JavaScript array containing the elements for the model. +[@equalityTest@] JavaScript function which takes two parameters, compares them +for equality, and returns a boolean. This is used by all the modes except +@ByReset@. If no function is set then the model will use the JavaScript equals +operator by default. +[@keyFunction@] JavaScript function which takes a single parameter and +returns a string key for use by the @ByKey@ and @ByKeyNoReorder@ modes. If no +function is set then the model will use JavaScript's string conversion by +default. +-} +module Graphics.QML.Model () where diff --git a/src/Graphics/QML/Objects.hs b/src/Graphics/QML/Objects.hs --- a/src/Graphics/QML/Objects.hs +++ b/src/Graphics/QML/Objects.hs @@ -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 diff --git a/src/Graphics/QML/Objects/ParamNames.hs b/src/Graphics/QML/Objects/ParamNames.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Objects/ParamNames.hs @@ -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_ diff --git a/src/Graphics/QML/Objects/Weak.hs b/src/Graphics/QML/Objects/Weak.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Objects/Weak.hs @@ -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) diff --git a/test/Graphics/QML/Test/AutoListTest.hs b/test/Graphics/QML/Test/AutoListTest.hs new file mode 100644 --- /dev/null +++ b/test/Graphics/QML/Test/AutoListTest.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TypeFamilies #-} + +module Graphics.QML.Test.AutoListTest where + +import Graphics.QML.Marshal +import Graphics.QML.Objects +import Graphics.QML.Test.Framework +import Graphics.QML.Test.MayGen +import Graphics.QML.Test.TestObject +import Graphics.QML.Test.ScriptDSL (Expr, Prog) +import qualified Graphics.QML.Test.ScriptDSL as S + +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen +import Control.Applicative +import Data.Int +import Data.Monoid +import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T +import Data.Typeable + +data Mode = ByReset | ByIndex | ByKey | ByKeyNoReorder + deriving (Bounded, Enum, Eq, Show, Typeable) + +instance Marshal Mode where + type MarshalMode Mode c d = ModeBidi c + marshaller = bidiMarshaller toEnum fromEnum + +instance S.Literal Mode where + literal ByReset = S.Expr $ showString "AutoListModel.ByReset" + literal ByIndex = S.Expr $ showString "AutoListModel.ByIndex" + literal ByKey = S.Expr $ showString "AutoListModel.ByKey" + literal ByKeyNoReorder = S.Expr $ showString "AutoListModel.ByKeyNoReorder" + +data AutoListTest + = CreateAutoList Int + deriving (Eq, Show, Typeable) + +data AutoList + = SetSource [Int32] + | SetMode Mode + deriving (Eq, Show, Typeable) + +qtN, hsN :: Int -> Int +qtN n = 2*n+0 +hsN n = 2*n+1 + +autoListType :: TestType +autoListType = TestType (Proxy :: Proxy AutoList) + +testCode :: Text +testCode = T.pack $ unlines [ + "import QtQuick 2.0;", + "import HsQML.Model 1.0;", + "Item {", + " id: obj;", + " Repeater {", + " id: rep;", + " model: AutoListModel { onSourceChanged: tmr.start(); }", + " Item { property var value : modelData; }", + " }", + " property var model : rep.model;", + " Timer { id: tmr; interval: 50; onTriggered: obj.ready(); }", + " signal ready;", + " function get() {", + " var xs = [];", + " for (var i=0; i + testEnvSetJ n autoListType s) + actionRemote (CreateAutoList n) _ = + (S.saveVar (qtN n) (S.call (S.sym "Qt" `S.dot` "createQmlObject") + [S.literal testCode, S.sym "page", S.literal $ T.pack "dyn"])) <> + (S.saveVar (hsN n) (S.call (S.sym "create") [S.literal n])) + mockObjDef = [ + defMethod "create" $ \m n -> checkAction m (CreateAutoList n) + (forkMockObj m :: IO (ObjRef (MockObj AutoList)))] + +instance TestAction AutoList where + legalActionIn _ _ = True + nextActionsFor env = fromGen $ oneof [ + SetSource <$> arbitrary, + SetMode <$> arbitraryBoundedEnum] + updateEnvRaw _ = testEnvStep + actionRemote (SetSource xs) n = + S.makeCont [] ( + S.connect (S.var (qtN n) `S.dot` "ready") S.contVar <> + S.set (S.var (qtN n) `S.dot` "model" `S.dot` "source") + (S.literal xs)) <> + S.disconnect (S.var (qtN n) `S.dot` "ready") S.callee <> + S.eval (S.call (S.var (hsN n) `S.dot` "sourceSet") [ + S.call (S.var (qtN n) `S.dot` "get") []]) + actionRemote (SetMode x) n = + S.set (S.var (qtN n) `S.dot` "model" `S.dot` "mode") (S.literal x) <> + S.eval (S.call (S.var (hsN n) `S.dot` "modeSet") [S.literal x]) + mockObjDef = [ + defMethod "sourceSet" $ \m xs -> + checkAction m (SetSource xs) $ return (), + defMethod "modeSet" $ \m x -> + checkAction m (SetMode x) $ return ()] diff --git a/test/Graphics/QML/Test/DataTest.hs b/test/Graphics/QML/Test/DataTest.hs new file mode 100644 --- /dev/null +++ b/test/Graphics/QML/Test/DataTest.hs @@ -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 ())] diff --git a/test/Graphics/QML/Test/Framework.hs b/test/Graphics/QML/Test/Framework.hs --- a/test/Graphics/QML/Test/Framework.hs +++ b/test/Graphics/QML/Test/Framework.hs @@ -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 diff --git a/test/Graphics/QML/Test/GenURI.hs b/test/Graphics/QML/Test/GenURI.hs deleted file mode 100644 --- a/test/Graphics/QML/Test/GenURI.hs +++ /dev/null @@ -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 "" "" diff --git a/test/Graphics/QML/Test/Harness.hs b/test/Graphics/QML/Test/Harness.hs --- a/test/Graphics/QML/Test/Harness.hs +++ b/test/Graphics/QML/Test/Harness.hs @@ -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 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 diff --git a/test/Graphics/QML/Test/ScriptDSL.hs b/test/Graphics/QML/Test/ScriptDSL.hs --- a/test/Graphics/QML/Test/ScriptDSL.hs +++ b/test/Graphics/QML/Test/ScriptDSL.hs @@ -1,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 diff --git a/test/Graphics/QML/Test/SignalTest.hs b/test/Graphics/QML/Test/SignalTest.hs --- a/test/Graphics/QML/Test/SignalTest.hs +++ b/test/Graphics/QML/Test/SignalTest.hs @@ -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] diff --git a/test/Graphics/QML/Test/SimpleTest.hs b/test/Graphics/QML/Test/SimpleTest.hs --- a/test/Graphics/QML/Test/SimpleTest.hs +++ b/test/Graphics/QML/Test/SimpleTest.hs @@ -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 diff --git a/test/Test1.hs b/test/Test1.hs --- a/test/Test1.hs +++ b/test/Test1.hs @@ -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