diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ HsQML - Release History +release-0.2.0.1 - 2013.11.12 + + * Added check that MacOS uses primordial thread for event loop. + * Fixed missing upper bound on Qt version constraint. + release-0.2.0.0 - 2013.10.08 * Added support for firing QML signals. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -155,7 +155,8 @@ } qtVersionRange :: VersionRange -qtVersionRange = orLaterVersion $ Version [4,7] [] +qtVersionRange = intersectVersionRanges + (orLaterVersion $ Version [4,7] []) (earlierVersion $ Version [5,0] []) copyWithQt :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () diff --git a/cbits/HsQMLManager.cpp b/cbits/HsQMLManager.cpp --- a/cbits/HsQMLManager.cpp +++ b/cbits/HsQMLManager.cpp @@ -4,6 +4,9 @@ #include #include #include +#ifdef Q_WS_MAC +#include +#endif #include "HsQMLManager.h" #include "HsQMLObject.h" @@ -113,6 +116,14 @@ 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) { diff --git a/hsqml.cabal b/hsqml.cabal --- a/hsqml.cabal +++ b/hsqml.cabal @@ -1,5 +1,5 @@ Name: hsqml -Version: 0.2.0.0 +Version: 0.2.0.1 Cabal-version: >= 1.10 Build-type: Custom License: BSD3 @@ -49,6 +49,7 @@ Graphics.QML.Internal.BindCore Graphics.QML.Internal.JobQueue Graphics.QML.Internal.Marshal + Graphics.QML.Internal.MetaObj Graphics.QML.Internal.Objects Hs-source-dirs: src C-sources: @@ -73,7 +74,8 @@ if os(darwin) && !flag(UsePkgConfig) Frameworks: QtCore QtGui QtScript QtDeclarative else - Pkgconfig-depends: QtScript >= 4.7, QtDeclarative >= 4.7 + Pkgconfig-depends: + QtScript >= 4.7 && < 5.0, QtDeclarative >= 4.7 && < 5.0 Extra-libraries: stdc++ Test-Suite hsqml-test1 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 @@ -110,47 +110,3 @@ `Int', id `Ptr (Ptr ())'} -> `()' #} - -ofDynamicMetaObject :: CUInt -ofDynamicMetaObject = 0x01 - -mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask, - mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor, - mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable - :: CUInt -mfAccessPrivate = 0x00 -mfAccessProtected = 0x01 -mfAccessPublic = 0x02 -mfAccessMask = 0x03 -mfMethodMethod = 0x00 -mfMethodSignal = 0x04 -mfMethodSlot = 0x08 -mfMethodConstructor = 0x0c -mfMethodTypeMask = 0x0c -mfMethodCompatibility = 0x10 -mfMethodCloned = 0x20 -mfMethodScriptable = 0x40 - -pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet, - pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable, - pfResolveScriptable, pfStored, pfResolveStored, pfEditable, - pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt -pfInvalid = 0x00000000 -pfReadable = 0x00000001 -pfWritable = 0x00000002 -pfResettable = 0x00000004 -pfEnumOrFlag = 0x00000008 -pfStdCppSet = 0x00000100 -pfConstant = 0x00000400 -pfFinal = 0x00000800 -pfDesignable = 0x00001000 -pfResolveDesignable = 0x00002000 -pfScriptable = 0x00004000 -pfResolveScriptable = 0x00008000 -pfStored = 0x00010000 -pfResolveStored = 0x00020000 -pfEditable = 0x00040000 -pfResolveEditable = 0x00080000 -pfUser = 0x00100000 -pfResolveUser = 0x00200000 -pfNotify = 0x00400000 diff --git a/src/Graphics/QML/Internal/MetaObj.hs b/src/Graphics/QML/Internal/MetaObj.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/QML/Internal/MetaObj.hs @@ -0,0 +1,224 @@ +module Graphics.QML.Internal.MetaObj where + +import Graphics.QML.Internal.BindObj +import Graphics.QML.Internal.Marshal +import Graphics.QML.Internal.Objects + +import Control.Monad +import Control.Monad.Trans.State +import Data.Bits +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Foreign.C.Types +import Foreign.C.String +import Foreign.Ptr +import Foreign.Storable +import Foreign.Marshal.Array + +-- +-- Counted Reverse List +-- + +data CRList a = CRList { + crlLen :: !Int, + crlList :: [a] +} + +crlEmpty :: CRList a +crlEmpty = CRList 0 [] + +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) + +crlToNewArray :: (Storable b) => (a -> IO b) -> CRList a -> IO (Ptr b) +crlToNewArray f (CRList len lst) = do + ptr <- mallocArray len + pokeRev ptr lst len + return ptr + where pokeRev _ [] _ = return () + pokeRev p (x:xs) n = do + let n' = n-1 + x' <- f x + pokeElemOff p n' x' + pokeRev p xs n' + +-- +-- Meta Object Compiler +-- + +data MOCState = MOCState { + mData :: CRList CUInt, + mDataMethodsIdx :: Maybe Int, + mDataPropsIdx :: Maybe Int, + mStrData :: CRList CChar, + mStrDataMap :: Map String CUInt, + mFuncMethods :: CRList (Maybe UniformFunc), + mFuncProperties :: CRList (Maybe UniformFunc), + mMethodCount :: Int, + mSignalCount :: Int, + mPropertyCount :: Int +} + +-- | 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 + writeString name -- Class name + writeInt 0 >> writeInt 0 -- Class info + writeIntegral $ + mMethodCount enc + + mSignalCount enc -- Methods + writeIntegral $ + fromMaybe 0 $ mDataMethodsIdx enc -- Methods (data index) + writeIntegral $ mPropertyCount enc -- Properties + writeIntegral $ + fromMaybe 0 $ mDataPropsIdx enc -- Properties (data index) + writeInt 0 >> writeInt 0 -- Enums + 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 + 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 + +writeInt :: CUInt -> State MOCState () +writeInt int = do + state <- get + put $ state {mData = mData state `crlAppend1` int} + return () + +writeIntegral :: (Integral a) => a -> State MOCState () +writeIntegral int = + writeInt (fromIntegral int) + +writeString :: String -> State MOCState () +writeString str = do + state <- get + let msd = mStrData state + msdMap = mStrDataMap state + case (Map.lookup str msdMap) 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 + put $ state { + mStrData = msd', + mStrDataMap = msdMap'} + writeIntegral idx + +writeMethod :: Member tt -> State MOCState () +writeMethod m = do + idx <- get >>= return . crlLen . mData + writeString $ methodSignature m + writeString $ methodParameters m + writeString $ typeName $ memberType m + writeString "" + let (mc,sc,flags) = case memberKind m of + SignalMember -> (0,1,mfMethodSignal) + _ -> (1,0,0) + writeInt (mfAccessPublic .|. mfMethodScriptable .|. flags) + state <- get + put $ state { + mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx), + mMethodCount = mc + (mMethodCount state), + mSignalCount = sc + (mSignalCount state), + mFuncMethods = mFuncMethods state `crlAppend1` (Just $ memberFun m)} + return () + +writeProperty :: Member tt -> State MOCState () +writeProperty p = do + idx <- get >>= return . crlLen . mData + writeString $ memberName p + writeString $ typeName $ memberType p + writeInt (pfReadable .|. pfScriptable .|. + if (isJust $ memberFunAux p) then pfWritable else 0) + state <- get + put $ state { + mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx), + 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 + +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 ')') "" + +methodParameters :: Member tt -> String +methodParameters method = + replicate (flip (-) 1 $ length $ memberParams method) ',' + +-- +-- Constants +-- + +ofDynamicMetaObject :: CUInt +ofDynamicMetaObject = 0x01 + +mfAccessPrivate, mfAccessProtected, mfAccessPublic, mfAccessMask, + mfMethodMethod, mfMethodSignal, mfMethodSlot, mfMethodConstructor, + mfMethodTypeMask, mfMethodCompatibility, mfMethodCloned, mfMethodScriptable + :: CUInt +mfAccessPrivate = 0x00 +mfAccessProtected = 0x01 +mfAccessPublic = 0x02 +mfAccessMask = 0x03 +mfMethodMethod = 0x00 +mfMethodSignal = 0x04 +mfMethodSlot = 0x08 +mfMethodConstructor = 0x0c +mfMethodTypeMask = 0x0c +mfMethodCompatibility = 0x10 +mfMethodCloned = 0x20 +mfMethodScriptable = 0x40 + +pfInvalid, pfReadable, pfWritable, pfResettable, pfEnumOrFlag, pfStdCppSet, + pfConstant, pfFinal, pfDesignable, pfResolveDesignable, pfScriptable, + pfResolveScriptable, pfStored, pfResolveStored, pfEditable, + pfResolveEditable, pfUser, pfResolveUser, pfNotify :: CUInt +pfInvalid = 0x00000000 +pfReadable = 0x00000001 +pfWritable = 0x00000002 +pfResettable = 0x00000004 +pfEnumOrFlag = 0x00000008 +pfStdCppSet = 0x00000100 +pfConstant = 0x00000400 +pfFinal = 0x00000800 +pfDesignable = 0x00001000 +pfResolveDesignable = 0x00002000 +pfScriptable = 0x00004000 +pfResolveScriptable = 0x00008000 +pfStored = 0x00010000 +pfResolveStored = 0x00020000 +pfEditable = 0x00040000 +pfResolveEditable = 0x00080000 +pfUser = 0x00100000 +pfResolveUser = 0x00200000 +pfNotify = 0x00400000 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 @@ -49,22 +49,17 @@ import Graphics.QML.Internal.BindObj import Graphics.QML.Internal.JobQueue import Graphics.QML.Internal.Marshal +import Graphics.QML.Internal.MetaObj import Graphics.QML.Internal.Objects import Control.Concurrent.MVar -import Control.Monad import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State -import Control.Exception -import Data.Bits import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe import Data.Tagged import Data.Typeable import Data.IORef -import Foreign.C.Types -import Foreign.C.String import Foreign.Ptr import Foreign.Storable import Foreign.Marshal.Alloc @@ -73,27 +68,6 @@ import Numeric -- --- Counted Reverse List --- - -data CRList a = CRList { - crlLen :: !Int, - crlList :: [a] -} - -crlEmpty :: CRList a -crlEmpty = CRList 0 [] - -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) - --- -- ObjRef -- @@ -293,27 +267,7 @@ Just hndl -> return $ ClassRec hndl sigMap Nothing -> error ("Failed to create QML class '"++name++"'.") -crlToNewArray :: (Storable b) => (a -> IO b) -> CRList a -> IO (Ptr b) -crlToNewArray f (CRList len lst) = do - ptr <- mallocArray len - pokeRev ptr lst len - return ptr - where pokeRev _ [] _ = return () - pokeRev p (x:xs) n = do - let n' = n-1 - x' <- f x - pokeElemOff p n' x' - pokeRev p xs n' - -- --- Member --- - -filterMembers :: MemberKind -> [Member tt] -> [Member tt] -filterMembers k ms = - filter (\m -> k == memberKind m) ms - --- -- Method -- @@ -506,125 +460,3 @@ start $ cont [] mkSignalTypes = Tagged $ SignalTypeInfo [] - --- --- Meta Object Compiler --- - -data MOCState = MOCState { - mData :: CRList CUInt, - mDataMethodsIdx :: Maybe Int, - mDataPropsIdx :: Maybe Int, - mStrData :: CRList CChar, - mStrDataMap :: Map String CUInt, - mFuncMethods :: CRList (Maybe UniformFunc), - mFuncProperties :: CRList (Maybe UniformFunc), - mMethodCount :: Int, - mSignalCount :: Int, - mPropertyCount :: Int -} - --- | 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 - writeString name -- Class name - writeInt 0 >> writeInt 0 -- Class info - writeIntegral $ - mMethodCount enc + - mSignalCount enc -- Methods - writeIntegral $ - fromMaybe 0 $ mDataMethodsIdx enc -- Methods (data index) - writeIntegral $ mPropertyCount enc -- Properties - writeIntegral $ - fromMaybe 0 $ mDataPropsIdx enc -- Properties (data index) - writeInt 0 >> writeInt 0 -- Enums - 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 - writeInt 0 - in enc - -newMOCState :: MOCState -newMOCState = - MOCState crlEmpty Nothing Nothing crlEmpty Map.empty crlEmpty crlEmpty 0 0 0 - -writeInt :: CUInt -> State MOCState () -writeInt int = do - state <- get - put $ state {mData = mData state `crlAppend1` int} - return () - -writeIntegral :: (Integral a) => a -> State MOCState () -writeIntegral int = - writeInt (fromIntegral int) - -writeString :: String -> State MOCState () -writeString str = do - state <- get - let msd = mStrData state - msdMap = mStrDataMap state - case (Map.lookup str msdMap) 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 - put $ state { - mStrData = msd', - mStrDataMap = msdMap'} - writeIntegral idx - -writeMethod :: Member tt -> State MOCState () -writeMethod m = do - idx <- get >>= return . crlLen . mData - writeString $ methodSignature m - writeString $ methodParameters m - writeString $ typeName $ memberType m - writeString "" - let (mc,sc,flags) = case memberKind m of - SignalMember -> (0,1,mfMethodSignal) - _ -> (1,0,0) - writeInt (mfAccessPublic .|. mfMethodScriptable .|. flags) - state <- get - put $ state { - mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx), - mMethodCount = mc + (mMethodCount state), - mSignalCount = sc + (mSignalCount state), - mFuncMethods = mFuncMethods state `crlAppend1` (Just $ memberFun m)} - return () - -writeProperty :: Member tt -> State MOCState () -writeProperty p = do - idx <- get >>= return . crlLen . mData - writeString $ memberName p - writeString $ typeName $ memberType p - writeInt (pfReadable .|. pfScriptable .|. - if (isJust $ memberFunAux p) then pfWritable else 0) - state <- get - put $ state { - mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx), - 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 - -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 ')') "" - -methodParameters :: Member tt -> String -methodParameters method = - replicate (flip (-) 1 $ length $ memberParams method) ','