{-# LANGUAGE
ScopedTypeVariables,
TypeFamilies,
FlexibleContexts,
FlexibleInstances,
LiberalTypeSynonyms
#-}
module Graphics.QML.Objects (
ObjRef,
newObject,
newObjectDC,
fromObjRef,
AnyObjRef,
anyObjRef,
fromAnyObjRef,
Class,
newClass,
DefaultClass (
classMembers),
Member,
defMethod,
defMethod',
MethodSuffix,
defSignal,
defSignalNamedParams,
fireSignal,
SignalKey,
newSignalKey,
SignalKeyClass (
type SignalParams),
SignalSuffix,
defPropertyConst,
defPropertyRO,
defPropertySigRO,
defPropertyRW,
defPropertySigRW,
defPropertyConst',
defPropertyRO',
defPropertySigRO',
defPropertyRW',
defPropertySigRW'
) where
import Graphics.QML.Internal.BindCore
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 Graphics.QML.Internal.Types
import Graphics.QML.Objects.ParamNames
import Control.Concurrent.MVar
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.Array
import System.IO.Unsafe
import Numeric
newObject :: forall tt. Class tt -> tt -> IO (ObjRef tt)
newObject (Class cHndl) obj =
fmap ObjRef $ hsqmlCreateObject obj cHndl
newObjectDC :: forall tt. (DefaultClass tt) => tt -> IO (ObjRef tt)
newObjectDC obj = do
clazz <- getDefaultClass :: IO (Class tt)
newObject clazz obj
fromObjRef :: ObjRef tt -> tt
fromObjRef = unsafeDupablePerformIO . fromObjRefIO
anyObjRef :: ObjRef tt -> AnyObjRef
anyObjRef (ObjRef hndl) = AnyObjRef hndl
fromAnyObjRef :: (Typeable tt) => AnyObjRef -> Maybe (ObjRef tt)
fromAnyObjRef = unsafeDupablePerformIO . fromAnyObjRefIO
newtype Class tt = Class HsQMLClassHandle
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
data MemoStore k v = MemoStore (MVar (Map k v)) (IORef (Map k v))
newMemoStore :: IO (MemoStore k v)
newMemoStore = do
let m = Map.empty
mr <- newMVar m
ir <- newIORef m
return $ MemoStore mr ir
getFromMemoStore :: (Ord k) => MemoStore k v -> k -> IO v -> IO (Bool, v)
getFromMemoStore (MemoStore mr ir) key fn = do
fstMap <- readIORef ir
case Map.lookup key fstMap of
Just val -> return (False, val)
Nothing -> modifyMVar mr $ \sndMap -> do
case Map.lookup key sndMap of
Just val -> return (sndMap, (False, val))
Nothing -> do
val <- fn
let newMap = Map.insert key val sndMap
writeIORef ir newMap
return (newMap, (True, val))
class (Typeable tt) => DefaultClass tt where
classMembers :: [Member tt]
{-# NOINLINE defaultClassDb #-}
defaultClassDb :: MemoStore TypeRep HsQMLClassHandle
defaultClassDb = unsafePerformIO $ newMemoStore
getDefaultClass :: forall tt. (DefaultClass tt) => IO (Class tt)
getDefaultClass = do
let typ = typeOf (undefined :: tt)
(_, val) <- getFromMemoStore defaultClassDb typ $
createClass typ (classMembers :: [Member tt])
return (Class val)
data MethodTypeInfo = MethodTypeInfo {
methodParamTypes :: [TypeId],
methodReturnType :: TypeId
}
class MethodSuffix a where
mkMethodFunc :: Int -> a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodTypes :: Tagged a MethodTypeInfo
instance (Marshal a, CanGetFrom a ~ Yes, MethodSuffix b) =>
MethodSuffix (a -> b) where
mkMethodFunc n f pv = do
ptr <- errIO $ peekElemOff pv n
val <- mFromCVal ptr
mkMethodFunc (n+1) (f val) pv
return ()
mkMethodTypes =
let (MethodTypeInfo p r) =
untag (mkMethodTypes :: Tagged b MethodTypeInfo)
typ = untag (mTypeCVal :: Tagged a TypeId)
in Tagged $ MethodTypeInfo (typ:p) r
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 mToCVal val ptr
mkMethodTypes =
let typ = untag (mTypeCVal :: Tagged a TypeId)
in Tagged $ MethodTypeInfo [] typ
mkUniformFunc :: forall tt ms.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,
MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc f = \pt pv -> do
hndl <- hsqmlGetObjectFromPointer pt
this <- mFromHndl hndl
runErrIO $ mkMethodFunc 1 (f this) pv
newtype VoidIO = VoidIO {runVoidIO :: (IO ())}
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, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes,
MethodSuffix ms, IsVoidIO ms) => (tt -> ms) -> UniformFunc
mkSpecialFunc f = \pt pv -> do
hndl <- hsqmlGetObjectFromPointer pt
this <- mFromHndl hndl
runErrIO $ mkMethodFunc 0 (f this) pv
defMethod :: forall tt ms.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType tt ~ Yes, MethodSuffix ms) =>
String -> (tt -> ms) -> Member (GetObjType tt)
defMethod name f =
let crude = untag (mkMethodTypes :: Tagged ms MethodTypeInfo)
in Member MethodMember
name
(methodReturnType crude)
(map (\t->("",t)) $ methodParamTypes crude)
(mkUniformFunc f)
Nothing
Nothing
defMethod' :: forall obj ms. (Typeable obj, MethodSuffix ms) =>
String -> (ObjRef obj -> ms) -> Member obj
defMethod' = defMethod
data SignalTypeInfo = SignalTypeInfo {
signalParamTypes :: [TypeId]
}
defSignal ::
forall obj skv. (SignalKeyValue skv) => String -> skv -> Member obj
defSignal name key = defSignalNamedParams name key anonParams
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)
fireSignal ::
forall tt skv. (Marshal tt, CanPassTo tt ~ Yes, IsObjType tt ~ Yes,
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 ->
withActiveObject hndl $ cnt $ SignalData hndl slotIdx
Nothing ->
return ()
cont ps (SignalData hndl slotIdx) =
withArray (nullPtr:ps) (\pptr ->
hsqmlFireSignal hndl slotIdx pptr)
in mkSignalArgs start cont
data SignalData = SignalData HsQMLObjectHandle Int
newtype SignalKey p = SignalKey Unique
newSignalKey :: (SignalSuffix p) => IO (SignalKey p)
newSignalKey = fmap SignalKey $ newUnique
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
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, CanPassTo a ~ Yes, SignalSuffix b) =>
SignalSuffix (a -> b) where
type SignalParamNames (a -> b) = String -> SignalParamNames b
mkSignalArgs start cont param =
mkSignalArgs start (\ps usr ->
mWithCVal param (\ptr ->
cont (ptr:ps) usr))
mkSignalTypes =
let (SignalTypeInfo p) =
untag (mkSignalTypes :: Tagged b SignalTypeInfo)
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 []
defPropertyConst :: forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType 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
defPropertyRO :: forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType 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
defPropertySigRO :: forall tt tr skv.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType 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)
defPropertyRW :: forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType 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
defPropertySigRW :: forall tt tr skv.
(Marshal tt, CanGetFrom tt ~ Yes, IsObjType 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)
defPropertyConst' :: forall obj tr.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>
String -> (ObjRef obj -> IO tr) -> Member obj
defPropertyConst' = defPropertyConst
defPropertyRO' :: forall obj tr.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>
String -> (ObjRef obj -> IO tr) -> Member obj
defPropertyRO' = defPropertyRO
defPropertySigRO' :: forall obj tr skv.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes, SignalKeyValue skv) =>
String -> skv -> (ObjRef obj -> IO tr) -> Member obj
defPropertySigRO' = defPropertySigRO
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
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