{-# LANGUAGE
    ScopedTypeVariables,
    TypeFamilies,
    FlexibleContexts,
    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
  Class,
  newClass,
  DefaultClass (
    classMembers),
  Member,

  -- * Methods
  defMethod,
  defMethod',
  MethodSuffix,

  -- * Signals
  defSignal,
  defSignalNamedParams,
  fireSignal,
  SignalKey,
  newSignalKey,
  SignalKeyClass (
    type SignalParams),
  SignalSuffix,

  -- * Properties
  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

--
-- ObjRef
--

-- | Creates a QML object given a 'Class' and a Haskell value of type @tt@.
newObject :: forall tt. Class tt -> tt -> IO (ObjRef tt)
newObject :: forall tt. Class tt -> tt -> IO (ObjRef tt)
newObject (Class HsQMLClassHandle
cHndl) tt
obj =
  (HsQMLObjectHandle -> ObjRef tt)
-> IO HsQMLObjectHandle -> IO (ObjRef tt)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsQMLObjectHandle -> ObjRef tt
forall tt. HsQMLObjectHandle -> ObjRef tt
ObjRef (IO HsQMLObjectHandle -> IO (ObjRef tt))
-> IO HsQMLObjectHandle -> IO (ObjRef tt)
forall a b. (a -> b) -> a -> b
$ tt -> HsQMLClassHandle -> IO HsQMLObjectHandle
forall a. a -> HsQMLClassHandle -> IO HsQMLObjectHandle
hsqmlCreateObject tt
obj HsQMLClassHandle
cHndl

-- | 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 :: forall tt. DefaultClass tt => tt -> IO (ObjRef tt)
newObjectDC tt
obj = do
  Class tt
clazz <- IO (Class tt)
forall tt. DefaultClass tt => IO (Class tt)
getDefaultClass :: IO (Class tt)
  Class tt -> tt -> IO (ObjRef tt)
forall tt. Class tt -> tt -> IO (ObjRef tt)
newObject Class tt
clazz tt
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 :: forall tt. ObjRef tt -> tt
fromObjRef = IO tt -> tt
forall a. IO a -> a
unsafeDupablePerformIO (IO tt -> tt) -> (ObjRef tt -> IO tt) -> ObjRef tt -> tt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjRef tt -> IO tt
forall tt. ObjRef tt -> IO tt
fromObjRefIO

-- | Upcasts an 'ObjRef' into an 'AnyObjRef'.
anyObjRef :: ObjRef tt -> AnyObjRef
anyObjRef :: forall tt. ObjRef tt -> AnyObjRef
anyObjRef (ObjRef HsQMLObjectHandle
hndl) = HsQMLObjectHandle -> AnyObjRef
AnyObjRef HsQMLObjectHandle
hndl

-- | Attempts to downcast an 'AnyObjRef' into an 'ObjRef' with the specific
-- underlying Haskell type @tt@.
fromAnyObjRef :: (Typeable tt) => AnyObjRef -> Maybe (ObjRef tt)
fromAnyObjRef :: forall tt. Typeable tt => AnyObjRef -> Maybe (ObjRef tt)
fromAnyObjRef = IO (Maybe (ObjRef tt)) -> Maybe (ObjRef tt)
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe (ObjRef tt)) -> Maybe (ObjRef tt))
-> (AnyObjRef -> IO (Maybe (ObjRef tt)))
-> AnyObjRef
-> Maybe (ObjRef tt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyObjRef -> IO (Maybe (ObjRef tt))
forall tt. Typeable tt => AnyObjRef -> IO (Maybe (ObjRef tt))
fromAnyObjRefIO

--
-- Class
--

-- | 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 :: forall tt. Typeable tt => [Member tt] -> IO (Class tt)
newClass = (HsQMLClassHandle -> Class tt)
-> IO HsQMLClassHandle -> IO (Class tt)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsQMLClassHandle -> Class tt
forall tt. HsQMLClassHandle -> Class tt
Class (IO HsQMLClassHandle -> IO (Class tt))
-> ([Member tt] -> IO HsQMLClassHandle)
-> [Member tt]
-> IO (Class tt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> [Member tt] -> IO HsQMLClassHandle
forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle
createClass (tt -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (tt
forall a. HasCallStack => a
undefined :: tt))

createClass :: forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle
createClass :: forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle
createClass TypeRep
typRep [Member tt]
ms = do
  IO ()
hsqmlInit
  CInt
classId <- IO CInt
hsqmlGetNextClassId
  let constrs :: TypeRep -> [TyCon]
constrs TypeRep
t = TypeRep -> TyCon
typeRepTyCon TypeRep
t TyCon -> [TyCon] -> [TyCon]
forall a. a -> [a] -> [a]
: ((TypeRep -> [TyCon]) -> [TypeRep] -> [TyCon]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap TypeRep -> [TyCon]
constrs ([TypeRep] -> [TyCon]) -> [TypeRep] -> [TyCon]
forall a b. (a -> b) -> a -> b
$ TypeRep -> [TypeRep]
typeRepArgs TypeRep
t)
      name :: String
name = (TyCon -> (String -> String) -> String -> String)
-> (String -> String) -> [TyCon] -> String -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\TyCon
c String -> String
s -> String -> String -> String
showString (TyCon -> String
tyConName TyCon
c) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          Char -> String -> String
showChar Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
s) String -> String
forall a. a -> a
id (TypeRep -> [TyCon]
constrs TypeRep
typRep) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ CInt -> String -> String
forall a. Integral a => a -> String -> String
showInt CInt
classId String
""
      ms' :: [Member tt]
ms' = [Member tt]
ms [Member tt] -> [Member tt] -> [Member tt]
forall a. [a] -> [a] -> [a]
++ [Member tt] -> [Member tt]
forall tt. [Member tt] -> [Member tt]
implicitSignals [Member tt]
ms
      moc :: MOCState
moc = String -> [Member tt] -> MOCState
forall tt. String -> [Member tt] -> MOCState
compileClass String
name [Member tt]
ms'
      sigs :: [Member tt]
sigs = MemberKind -> [Member tt] -> [Member tt]
forall tt. MemberKind -> [Member tt] -> [Member tt]
filterMembers MemberKind
SignalMember [Member tt]
ms'
      sigMap :: Map MemberKey Int
sigMap = [(MemberKey, Int)] -> Map MemberKey Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(MemberKey, Int)] -> Map MemberKey Int)
-> [(MemberKey, Int)] -> Map MemberKey Int
forall a b. (a -> b) -> a -> b
$ ([MemberKey] -> [Int] -> [(MemberKey, Int)])
-> [Int] -> [MemberKey] -> [(MemberKey, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [MemberKey] -> [Int] -> [(MemberKey, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] ([MemberKey] -> [(MemberKey, Int)])
-> [MemberKey] -> [(MemberKey, Int)]
forall a b. (a -> b) -> a -> b
$ (Member tt -> MemberKey) -> [Member tt] -> [MemberKey]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe MemberKey -> MemberKey
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe MemberKey -> MemberKey)
-> (Member tt -> Maybe MemberKey) -> Member tt -> MemberKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Member tt -> Maybe MemberKey
forall tt. Member tt -> Maybe MemberKey
memberKey) [Member tt]
sigs
      info :: ClassInfo
info = TypeRep -> Map MemberKey Int -> ClassInfo
ClassInfo TypeRep
typRep Map MemberKey Int
sigMap
      maybeMarshalFunc :: Maybe UniformFunc -> IO (FunPtr UniformFunc)
maybeMarshalFunc = IO (FunPtr UniformFunc)
-> (UniformFunc -> IO (FunPtr UniformFunc))
-> Maybe UniformFunc
-> IO (FunPtr UniformFunc)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FunPtr UniformFunc -> IO (FunPtr UniformFunc)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr UniformFunc
forall a. FunPtr a
nullFunPtr) UniformFunc -> IO (FunPtr UniformFunc)
marshalFunc
  Ptr CUInt
metaDataPtr <- (CUInt -> IO CUInt) -> CRList CUInt -> IO (Ptr CUInt)
forall b a. Storable b => (a -> IO b) -> CRList a -> IO (Ptr b)
crlToNewArray CUInt -> IO CUInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MOCState -> CRList CUInt
mData MOCState
moc)
  Ptr CUInt
metaStrInfoPtr <- (CUInt -> IO CUInt) -> CRList CUInt -> IO (Ptr CUInt)
forall b a. Storable b => (a -> IO b) -> CRList a -> IO (Ptr b)
crlToNewArray CUInt -> IO CUInt
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MOCState -> CRList CUInt
mStrInfo MOCState
moc)
  Ptr CChar
metaStrCharPtr <- (CChar -> IO CChar) -> CRList CChar -> IO (Ptr CChar)
forall b a. Storable b => (a -> IO b) -> CRList a -> IO (Ptr b)
crlToNewArray CChar -> IO CChar
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MOCState -> CRList CChar
mStrChar MOCState
moc)
  Ptr (FunPtr UniformFunc)
methodsPtr <- (Maybe UniformFunc -> IO (FunPtr UniformFunc))
-> CRList (Maybe UniformFunc) -> IO (Ptr (FunPtr UniformFunc))
forall b a. Storable b => (a -> IO b) -> CRList a -> IO (Ptr b)
crlToNewArray Maybe UniformFunc -> IO (FunPtr UniformFunc)
maybeMarshalFunc (MOCState -> CRList (Maybe UniformFunc)
mFuncMethods MOCState
moc)
  Ptr (FunPtr UniformFunc)
propsPtr <- (Maybe UniformFunc -> IO (FunPtr UniformFunc))
-> CRList (Maybe UniformFunc) -> IO (Ptr (FunPtr UniformFunc))
forall b a. Storable b => (a -> IO b) -> CRList a -> IO (Ptr b)
crlToNewArray Maybe UniformFunc -> IO (FunPtr UniformFunc)
maybeMarshalFunc (MOCState -> CRList (Maybe UniformFunc)
mFuncProperties MOCState
moc)
  Maybe HsQMLClassHandle
maybeHndl <- Ptr CUInt
-> Ptr CUInt
-> Ptr CChar
-> ClassInfo
-> Ptr (FunPtr UniformFunc)
-> Ptr (FunPtr UniformFunc)
-> IO (Maybe HsQMLClassHandle)
hsqmlCreateClass
      Ptr CUInt
metaDataPtr Ptr CUInt
metaStrInfoPtr Ptr CChar
metaStrCharPtr ClassInfo
info Ptr (FunPtr UniformFunc)
methodsPtr Ptr (FunPtr UniformFunc)
propsPtr
  case Maybe HsQMLClassHandle
maybeHndl of
      Just HsQMLClassHandle
hndl -> HsQMLClassHandle -> IO HsQMLClassHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HsQMLClassHandle
hndl
      Maybe HsQMLClassHandle
Nothing -> String -> IO HsQMLClassHandle
forall a. HasCallStack => String -> a
error (String
"Failed to create QML class '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'.")

implicitSignals :: [Member tt] -> [Member tt]
implicitSignals :: forall tt. [Member tt] -> [Member tt]
implicitSignals [Member tt]
ms =
    let sigKeys :: Set MemberKey
sigKeys = [MemberKey] -> Set MemberKey
forall a. Ord a => [a] -> Set a
Set.fromList ([MemberKey] -> Set MemberKey) -> [MemberKey] -> Set MemberKey
forall a b. (a -> b) -> a -> b
$ (Member tt -> Maybe MemberKey) -> [Member tt] -> [MemberKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Member tt -> Maybe MemberKey
forall tt. Member tt -> Maybe MemberKey
memberKey ([Member tt] -> [MemberKey]) -> [Member tt] -> [MemberKey]
forall a b. (a -> b) -> a -> b
$
            MemberKind -> [Member tt] -> [Member tt]
forall tt. MemberKind -> [Member tt] -> [Member tt]
filterMembers MemberKind
SignalMember [Member tt]
ms
        impKeys :: [MemberKey]
impKeys = (MemberKey -> Bool) -> [MemberKey] -> [MemberKey]
forall a. (a -> Bool) -> [a] -> [a]
filter ((MemberKey -> Set MemberKey -> Bool)
-> Set MemberKey -> MemberKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip MemberKey -> Set MemberKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember Set MemberKey
sigKeys) ([MemberKey] -> [MemberKey]) -> [MemberKey] -> [MemberKey]
forall a b. (a -> b) -> a -> b
$ (Member tt -> Maybe MemberKey) -> [Member tt] -> [MemberKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Member tt -> Maybe MemberKey
forall tt. Member tt -> Maybe MemberKey
memberKey ([Member tt] -> [MemberKey]) -> [Member tt] -> [MemberKey]
forall a b. (a -> b) -> a -> b
$
            MemberKind -> [Member tt] -> [Member tt]
forall tt. MemberKind -> [Member tt] -> [Member tt]
filterMembers MemberKind
PropertyMember [Member tt]
ms
        impMember :: a -> MemberKey -> Member tt
impMember a
i MemberKey
k = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
SignalMember
            (String
"__implicitSignal" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
i)
            TypeId
tyVoid
            []
            (\Ptr ()
_ Ptr (Ptr ())
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
            Maybe UniformFunc
forall a. Maybe a
Nothing
            (MemberKey -> Maybe MemberKey
forall a. a -> Maybe a
Just MemberKey
k)
    in ((Int, MemberKey) -> Member tt)
-> [(Int, MemberKey)] -> [Member tt]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> MemberKey -> Member tt) -> (Int, MemberKey) -> Member tt
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> MemberKey -> Member tt
forall {a} {tt}. Show a => a -> MemberKey -> Member tt
impMember) ([(Int, MemberKey)] -> [Member tt])
-> [(Int, MemberKey)] -> [Member tt]
forall a b. (a -> b) -> a -> b
$ [Int] -> [MemberKey] -> [(Int, MemberKey)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0::Int)..] [MemberKey]
impKeys

--
-- Default Class
--

data MemoStore k v = MemoStore (MVar (Map k v)) (IORef (Map k v))

newMemoStore :: IO (MemoStore k v)
newMemoStore :: forall k v. IO (MemoStore k v)
newMemoStore = do
    let m :: Map k a
m = Map k a
forall k a. Map k a
Map.empty
    MVar (Map k v)
mr <- Map k v -> IO (MVar (Map k v))
forall a. a -> IO (MVar a)
newMVar Map k v
forall k a. Map k a
m
    IORef (Map k v)
ir <- Map k v -> IO (IORef (Map k v))
forall a. a -> IO (IORef a)
newIORef Map k v
forall k a. Map k a
m
    MemoStore k v -> IO (MemoStore k v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MemoStore k v -> IO (MemoStore k v))
-> MemoStore k v -> IO (MemoStore k v)
forall a b. (a -> b) -> a -> b
$ MVar (Map k v) -> IORef (Map k v) -> MemoStore k v
forall k v. MVar (Map k v) -> IORef (Map k v) -> MemoStore k v
MemoStore MVar (Map k v)
mr IORef (Map k v)
ir

getFromMemoStore :: (Ord k) => MemoStore k v -> k -> IO v -> IO (Bool, v)
getFromMemoStore :: forall k v. Ord k => MemoStore k v -> k -> IO v -> IO (Bool, v)
getFromMemoStore (MemoStore MVar (Map k v)
mr IORef (Map k v)
ir) k
key IO v
fn = do
    Map k v
fstMap <- IORef (Map k v) -> IO (Map k v)
forall a. IORef a -> IO a
readIORef IORef (Map k v)
ir
    case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k v
fstMap of
        Just v
val -> (Bool, v) -> IO (Bool, v)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, v
val)
        Maybe v
Nothing  -> MVar (Map k v)
-> (Map k v -> IO (Map k v, (Bool, v))) -> IO (Bool, v)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Map k v)
mr ((Map k v -> IO (Map k v, (Bool, v))) -> IO (Bool, v))
-> (Map k v -> IO (Map k v, (Bool, v))) -> IO (Bool, v)
forall a b. (a -> b) -> a -> b
$ \Map k v
sndMap -> do
            case k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
key Map k v
sndMap of
                Just v
val -> (Map k v, (Bool, v)) -> IO (Map k v, (Bool, v))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k v
sndMap, (Bool
False, v
val))
                Maybe v
Nothing  -> do
                    v
val <- IO v
fn
                    let newMap :: Map k v
newMap = k -> v -> Map k v -> Map k v
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
key v
val Map k v
sndMap
                    IORef (Map k v) -> Map k v -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Map k v)
ir Map k v
newMap
                    (Map k v, (Bool, v)) -> IO (Map k v, (Bool, v))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map k v
newMap, (Bool
True, v
val))

-- | 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 defaultClassDb #-}
defaultClassDb :: MemoStore TypeRep HsQMLClassHandle
defaultClassDb :: MemoStore TypeRep HsQMLClassHandle
defaultClassDb = IO (MemoStore TypeRep HsQMLClassHandle)
-> MemoStore TypeRep HsQMLClassHandle
forall a. IO a -> a
unsafePerformIO (IO (MemoStore TypeRep HsQMLClassHandle)
 -> MemoStore TypeRep HsQMLClassHandle)
-> IO (MemoStore TypeRep HsQMLClassHandle)
-> MemoStore TypeRep HsQMLClassHandle
forall a b. (a -> b) -> a -> b
$ IO (MemoStore TypeRep HsQMLClassHandle)
forall k v. IO (MemoStore k v)
newMemoStore

getDefaultClass :: forall tt. (DefaultClass tt) => IO (Class tt)
getDefaultClass :: forall tt. DefaultClass tt => IO (Class tt)
getDefaultClass = do
    let typ :: TypeRep
typ = tt -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (tt
forall a. HasCallStack => a
undefined :: tt)
    (Bool
_, HsQMLClassHandle
val) <- MemoStore TypeRep HsQMLClassHandle
-> TypeRep -> IO HsQMLClassHandle -> IO (Bool, HsQMLClassHandle)
forall k v. Ord k => MemoStore k v -> k -> IO v -> IO (Bool, v)
getFromMemoStore MemoStore TypeRep HsQMLClassHandle
defaultClassDb TypeRep
typ (IO HsQMLClassHandle -> IO (Bool, HsQMLClassHandle))
-> IO HsQMLClassHandle -> IO (Bool, HsQMLClassHandle)
forall a b. (a -> b) -> a -> b
$
        TypeRep -> [Member tt] -> IO HsQMLClassHandle
forall tt. TypeRep -> [Member tt] -> IO HsQMLClassHandle
createClass TypeRep
typ ([Member tt]
forall tt. DefaultClass tt => [Member tt]
classMembers :: [Member tt])
    Class tt -> IO (Class tt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQMLClassHandle -> Class tt
forall tt. HsQMLClassHandle -> Class tt
Class HsQMLClassHandle
val)

--
-- Method
--

data MethodTypeInfo = MethodTypeInfo {
  MethodTypeInfo -> [TypeId]
methodParamTypes :: [TypeId],
  MethodTypeInfo -> TypeId
methodReturnType :: TypeId
}

-- | 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, CanGetFrom a ~ Yes, MethodSuffix b) =>
  MethodSuffix (a -> b) where
  mkMethodFunc :: Int -> (a -> b) -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc Int
n a -> b
f Ptr (Ptr ())
pv = do
    Ptr ()
ptr <- IO (Ptr ()) -> ErrIO (Ptr ())
forall a. IO a -> ErrIO a
errIO (IO (Ptr ()) -> ErrIO (Ptr ())) -> IO (Ptr ()) -> ErrIO (Ptr ())
forall a b. (a -> b) -> a -> b
$ Ptr (Ptr ()) -> Int -> IO (Ptr ())
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr (Ptr ())
pv Int
n
    a
val <- MFromCValFunc a
forall t. Marshal t => MFromCValFunc t
mFromCVal Ptr ()
ptr
    Int -> b -> Ptr (Ptr ()) -> ErrIO ()
forall a. MethodSuffix a => Int -> a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (a -> b
f a
val) Ptr (Ptr ())
pv
    () -> ErrIO ()
forall a. a -> MaybeT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  mkMethodTypes :: Tagged (a -> b) MethodTypeInfo
mkMethodTypes =
    let (MethodTypeInfo [TypeId]
p TypeId
r) =
          Tagged b MethodTypeInfo -> MethodTypeInfo
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged b MethodTypeInfo
forall a. MethodSuffix a => Tagged a MethodTypeInfo
mkMethodTypes :: Tagged b MethodTypeInfo)
        typ :: TypeId
typ = Tagged a TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged a TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged a TypeId)
    in MethodTypeInfo -> Tagged (a -> b) MethodTypeInfo
forall {k} (s :: k) b. b -> Tagged s b
Tagged (MethodTypeInfo -> Tagged (a -> b) MethodTypeInfo)
-> MethodTypeInfo -> Tagged (a -> b) MethodTypeInfo
forall a b. (a -> b) -> a -> b
$ [TypeId] -> TypeId -> MethodTypeInfo
MethodTypeInfo (TypeId
typTypeId -> [TypeId] -> [TypeId]
forall a. a -> [a] -> [a]
:[TypeId]
p) TypeId
r

instance (Marshal a, CanReturnTo a ~ Yes) =>
  MethodSuffix (IO a) where
  mkMethodFunc :: Int -> IO a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc Int
_ IO a
f Ptr (Ptr ())
pv = IO () -> ErrIO ()
forall a. IO a -> ErrIO a
errIO (IO () -> ErrIO ()) -> IO () -> ErrIO ()
forall a b. (a -> b) -> a -> b
$ do
    Ptr ()
ptr <- Ptr (Ptr ()) -> Int -> IO (Ptr ())
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr (Ptr ())
pv Int
0
    a
val <- IO a
f
    if Ptr ()
forall a. Ptr a
nullPtr Ptr () -> Ptr () -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr ()
ptr
    then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    else MToCValFunc a
forall t. Marshal t => MToCValFunc t
mToCVal a
val Ptr ()
ptr
  mkMethodTypes :: Tagged (IO a) MethodTypeInfo
mkMethodTypes =
    let typ :: TypeId
typ = Tagged a TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged a TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged a TypeId)
    in MethodTypeInfo -> Tagged (IO a) MethodTypeInfo
forall {k} (s :: k) b. b -> Tagged s b
Tagged (MethodTypeInfo -> Tagged (IO a) MethodTypeInfo)
-> MethodTypeInfo -> Tagged (IO a) MethodTypeInfo
forall a b. (a -> b) -> a -> b
$ [TypeId] -> TypeId -> MethodTypeInfo
MethodTypeInfo [] TypeId
typ

mkUniformFunc :: forall tt ms.
  (Marshal tt,
    MethodSuffix ms) =>
  (tt -> ms) -> UniformFunc
mkUniformFunc :: forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> ms
f = \Ptr ()
pt Ptr (Ptr ())
pv -> do
  HsQMLObjectHandle
hndl <- Ptr () -> IO HsQMLObjectHandle
hsqmlGetObjectFromPointer Ptr ()
pt
  tt
this <- MFromHndlFunc tt
forall t. Marshal t => MFromHndlFunc t
mFromHndl HsQMLObjectHandle
hndl
  ErrIO () -> IO ()
forall a. ErrIO a -> IO ()
runErrIO (ErrIO () -> IO ()) -> ErrIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ms -> Ptr (Ptr ()) -> ErrIO ()
forall a. MethodSuffix a => Int -> a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc Int
1 (tt -> ms
f tt
this) Ptr (Ptr ())
pv

newtype VoidIO = VoidIO {VoidIO -> IO ()
runVoidIO :: (IO ())}

instance MethodSuffix VoidIO where
    mkMethodFunc :: Int -> VoidIO -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc Int
_ VoidIO
f Ptr (Ptr ())
_ = IO () -> ErrIO ()
forall a. IO a -> ErrIO a
errIO (IO () -> ErrIO ()) -> IO () -> ErrIO ()
forall a b. (a -> b) -> a -> b
$ VoidIO -> IO ()
runVoidIO VoidIO
f
    mkMethodTypes :: Tagged VoidIO MethodTypeInfo
mkMethodTypes = MethodTypeInfo -> Tagged VoidIO MethodTypeInfo
forall {k} (s :: k) b. b -> Tagged s b
Tagged (MethodTypeInfo -> Tagged VoidIO MethodTypeInfo)
-> MethodTypeInfo -> Tagged VoidIO MethodTypeInfo
forall a b. (a -> b) -> a -> b
$ [TypeId] -> TypeId -> MethodTypeInfo
MethodTypeInfo [] TypeId
tyVoid

class IsVoidIO a
instance (IsVoidIO b) => IsVoidIO (a -> b)
instance IsVoidIO VoidIO

mkSpecialFunc
  :: forall tt ms.
    ( Marshal tt
    , MethodSuffix ms)
  => (tt -> ms)
  -> UniformFunc
mkSpecialFunc :: forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkSpecialFunc tt -> ms
f = \Ptr ()
pt Ptr (Ptr ())
pv -> do
    HsQMLObjectHandle
hndl <- Ptr () -> IO HsQMLObjectHandle
hsqmlGetObjectFromPointer Ptr ()
pt
    tt
this <- MFromHndlFunc tt
forall t. Marshal t => MFromHndlFunc t
mFromHndl HsQMLObjectHandle
hndl
    ErrIO () -> IO ()
forall a. ErrIO a -> IO ()
runErrIO (ErrIO () -> IO ()) -> ErrIO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ms -> Ptr (Ptr ()) -> ErrIO ()
forall a. MethodSuffix a => Int -> a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodFunc Int
0 (tt -> ms
f tt
this) Ptr (Ptr ())
pv

-- | Defines a named method using a function @f@ in the IO monad.
--
-- The first argument to @f@ receives the \"this\" object and hence must match
-- the type of the class on which the method is being defined. Subsequently,
-- there may be zero or more parameter arguments followed by an optional return
-- argument in the IO monad.
defMethod :: forall tt ms.
  (Marshal tt, MethodSuffix ms) =>
  String -> (tt -> ms) -> Member (GetObjType tt)
defMethod :: forall tt ms.
(Marshal tt, MethodSuffix ms) =>
String -> (tt -> ms) -> Member (GetObjType tt)
defMethod String
name tt -> ms
f =
  let crude :: MethodTypeInfo
crude = Tagged ms MethodTypeInfo -> MethodTypeInfo
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged ms MethodTypeInfo
forall a. MethodSuffix a => Tagged a MethodTypeInfo
mkMethodTypes :: Tagged ms MethodTypeInfo)
  in MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
MethodMember
       String
name
       (MethodTypeInfo -> TypeId
methodReturnType MethodTypeInfo
crude)
       ((TypeId -> (String, TypeId)) -> [TypeId] -> [(String, TypeId)]
forall a b. (a -> b) -> [a] -> [b]
map (\TypeId
t->(String
"",TypeId
t)) ([TypeId] -> [(String, TypeId)]) -> [TypeId] -> [(String, TypeId)]
forall a b. (a -> b) -> a -> b
$ MethodTypeInfo -> [TypeId]
methodParamTypes MethodTypeInfo
crude)
       ((tt -> ms) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> ms
f)
       Maybe UniformFunc
forall a. Maybe a
Nothing
       Maybe MemberKey
forall a. Maybe a
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' :: forall obj ms.
(Typeable obj, MethodSuffix ms) =>
String -> (ObjRef obj -> ms) -> Member obj
defMethod' = String -> (ObjRef obj -> ms) -> Member obj
String -> (ObjRef obj -> ms) -> Member (GetObjType (ObjRef obj))
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
String -> (tt -> ms) -> Member (GetObjType tt)
defMethod

--
-- Signal
--

data SignalTypeInfo = SignalTypeInfo {
  SignalTypeInfo -> [TypeId]
signalParamTypes :: [TypeId]
}

-- | 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 skv. (SignalKeyValue skv) => String -> skv -> Member obj
defSignal :: forall obj skv. SignalKeyValue skv => String -> skv -> Member obj
defSignal String
name skv
key = String
-> skv
-> ParamNames (SignalParamNames (SignalValueParams skv))
-> Member obj
forall obj skv.
SignalKeyValue skv =>
String
-> skv
-> ParamNames (SignalParamNames (SignalValueParams skv))
-> Member obj
defSignalNamedParams String
name skv
key ParamNames (SignalParamNames (SignalValueParams skv))
forall a. AnonParams a => ParamNames a
anonParams

-- | 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 :: forall obj skv.
SignalKeyValue skv =>
String
-> skv
-> ParamNames (SignalParamNames (SignalValueParams skv))
-> Member obj
defSignalNamedParams String
name skv
key ParamNames (SignalParamNames (SignalValueParams skv))
pnames =
    let crude :: SignalTypeInfo
crude = Tagged (SignalValueParams skv) SignalTypeInfo -> SignalTypeInfo
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged (SignalValueParams skv) SignalTypeInfo
forall ss. SignalSuffix ss => Tagged ss SignalTypeInfo
mkSignalTypes ::
            Tagged (SignalValueParams skv) SignalTypeInfo)
    in MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member obj
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
SignalMember
        String
name
        TypeId
tyVoid
        (ParamNames (SignalParamNames (SignalValueParams skv)) -> [String]
forall a. ParamNames a -> [String]
paramNames ParamNames (SignalParamNames (SignalValueParams skv))
pnames [String] -> [TypeId] -> [(String, TypeId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` SignalTypeInfo -> [TypeId]
signalParamTypes SignalTypeInfo
crude)
        (\Ptr ()
_ Ptr (Ptr ())
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
        Maybe UniformFunc
forall a. Maybe a
Nothing
        (MemberKey -> Maybe MemberKey
forall a. a -> Maybe a
Just (MemberKey -> Maybe MemberKey) -> MemberKey -> Maybe MemberKey
forall a b. (a -> b) -> a -> b
$ skv -> MemberKey
forall skv. SignalKeyValue skv => skv -> MemberKey
signalKey skv
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 skv. (Marshal tt,
        SignalKeyValue skv) => skv -> tt -> SignalValueParams skv
fireSignal :: forall tt skv.
(Marshal tt, SignalKeyValue skv) =>
skv -> tt -> SignalValueParams skv
fireSignal skv
key tt
this =
    let start :: (SignalData -> IO ()) -> IO ()
start SignalData -> IO ()
cnt = IO () -> IO ()
postJob (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
           HsQMLObjectHandle
hndl <- MToHndlFunc tt
forall t. Marshal t => MToHndlFunc t
mToHndl tt
this
           ClassInfo
info <- HsQMLObjectHandle -> IO ClassInfo
hsqmlObjectGetHsTyperep HsQMLObjectHandle
hndl
           let slotMay :: Maybe Int
slotMay = MemberKey -> Map MemberKey Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (skv -> MemberKey
forall skv. SignalKeyValue skv => skv -> MemberKey
signalKey skv
key) (Map MemberKey Int -> Maybe Int) -> Map MemberKey Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ClassInfo -> Map MemberKey Int
cinfoSignals ClassInfo
info
           case Maybe Int
slotMay of
                Just Int
slotIdx ->
                    HsQMLObjectHandle -> IO () -> IO ()
withActiveObject HsQMLObjectHandle
hndl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SignalData -> IO ()
cnt (SignalData -> IO ()) -> SignalData -> IO ()
forall a b. (a -> b) -> a -> b
$ HsQMLObjectHandle -> Int -> SignalData
SignalData HsQMLObjectHandle
hndl Int
slotIdx
                Maybe Int
Nothing ->
                    () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Should warn?
        cont :: [Ptr ()] -> SignalData -> IO ()
cont [Ptr ()]
ps (SignalData HsQMLObjectHandle
hndl Int
slotIdx) =
            [Ptr ()] -> (Ptr (Ptr ()) -> IO ()) -> IO ()
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray (Ptr ()
forall a. Ptr a
nullPtrPtr () -> [Ptr ()] -> [Ptr ()]
forall a. a -> [a] -> [a]
:[Ptr ()]
ps) (\Ptr (Ptr ())
pptr ->
                HsQMLObjectHandle -> Int -> Ptr (Ptr ()) -> IO ()
hsqmlFireSignal HsQMLObjectHandle
hndl Int
slotIdx Ptr (Ptr ())
pptr)
    in ((SignalData -> IO ()) -> IO ())
-> ([Ptr ()] -> SignalData -> IO ()) -> SignalValueParams skv
forall ss usr.
SignalSuffix ss =>
((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss
forall usr.
((usr -> IO ()) -> IO ())
-> ([Ptr ()] -> usr -> IO ()) -> SignalValueParams skv
mkSignalArgs (SignalData -> IO ()) -> IO ()
start [Ptr ()] -> SignalData -> IO ()
cont

data SignalData = SignalData HsQMLObjectHandle Int

-- | 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 :: forall p. IO (SignalKey p)
newSignalKey = (Unique -> SignalKey p) -> IO Unique -> IO (SignalKey p)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Unique -> SignalKey p
forall p. Unique -> SignalKey p
SignalKey IO Unique
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 :: Proxy sk -> MemberKey
signalKey Proxy sk
_ = TypeRep -> MemberKey
TypeKey (TypeRep -> MemberKey) -> TypeRep -> MemberKey
forall a b. (a -> b) -> a -> b
$ sk -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (sk
forall a. HasCallStack => a
undefined :: sk)

instance (SignalSuffix p) => SignalKeyValue (SignalKey p) where
    type SignalValueParams (SignalKey p) = p
    signalKey :: SignalKey p -> MemberKey
signalKey (SignalKey Unique
u) = Unique -> MemberKey
DataKey Unique
u

-- | Supports marshalling an arbitrary number of arguments into a QML signal.
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 :: forall usr.
((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> a -> b
mkSignalArgs (usr -> IO ()) -> IO ()
start [Ptr ()] -> usr -> IO ()
cont a
param =
        ((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> b
forall ss usr.
SignalSuffix ss =>
((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> ss
forall usr.
((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> b
mkSignalArgs (usr -> IO ()) -> IO ()
start (\[Ptr ()]
ps usr
usr ->
            a -> (Ptr () -> IO ()) -> IO ()
MWithCValFunc a
forall t. Marshal t => MWithCValFunc t
mWithCVal a
param (\Ptr ()
ptr ->
                [Ptr ()] -> usr -> IO ()
cont (Ptr ()
ptrPtr () -> [Ptr ()] -> [Ptr ()]
forall a. a -> [a] -> [a]
:[Ptr ()]
ps) usr
usr))
    mkSignalTypes :: Tagged (a -> b) SignalTypeInfo
mkSignalTypes =
        let (SignalTypeInfo [TypeId]
p) =
                Tagged b SignalTypeInfo -> SignalTypeInfo
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged b SignalTypeInfo
forall ss. SignalSuffix ss => Tagged ss SignalTypeInfo
mkSignalTypes :: Tagged b SignalTypeInfo)
            typ :: TypeId
typ = Tagged a TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged a TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged a TypeId)
        in SignalTypeInfo -> Tagged (a -> b) SignalTypeInfo
forall {k} (s :: k) b. b -> Tagged s b
Tagged (SignalTypeInfo -> Tagged (a -> b) SignalTypeInfo)
-> SignalTypeInfo -> Tagged (a -> b) SignalTypeInfo
forall a b. (a -> b) -> a -> b
$ [TypeId] -> SignalTypeInfo
SignalTypeInfo (TypeId
typTypeId -> [TypeId] -> [TypeId]
forall a. a -> [a] -> [a]
:[TypeId]
p)

instance SignalSuffix (IO ()) where
    type SignalParamNames (IO ()) = ()
    mkSignalArgs :: forall usr.
((usr -> IO ()) -> IO ()) -> ([Ptr ()] -> usr -> IO ()) -> IO ()
mkSignalArgs (usr -> IO ()) -> IO ()
start [Ptr ()] -> usr -> IO ()
cont =
        (usr -> IO ()) -> IO ()
start ((usr -> IO ()) -> IO ()) -> (usr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ [Ptr ()] -> usr -> IO ()
cont []
    mkSignalTypes :: Tagged (IO ()) SignalTypeInfo
mkSignalTypes =
        SignalTypeInfo -> Tagged (IO ()) SignalTypeInfo
forall {k} (s :: k) b. b -> Tagged s b
Tagged (SignalTypeInfo -> Tagged (IO ()) SignalTypeInfo)
-> SignalTypeInfo -> Tagged (IO ()) SignalTypeInfo
forall a b. (a -> b) -> a -> b
$ [TypeId] -> SignalTypeInfo
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 :: forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,
 CanReturnTo tr ~ Yes) =>
String -> (tt -> IO tr) -> Member (GetObjType tt)
defPropertyConst String
name tt -> IO tr
g = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
ConstPropertyMember
    String
name
    (Tagged tr TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged tr TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged tr TypeId))
    []
    ((tt -> IO tr) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> IO tr
g)
    Maybe UniformFunc
forall a. Maybe a
Nothing
    Maybe MemberKey
forall a. Maybe a
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 :: forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,
 CanReturnTo tr ~ Yes) =>
String -> (tt -> IO tr) -> Member (GetObjType tt)
defPropertyRO String
name tt -> IO tr
g = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
PropertyMember
    String
name
    (Tagged tr TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged tr TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged tr TypeId))
    []
    ((tt -> IO tr) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> IO tr
g)
    Maybe UniformFunc
forall a. Maybe a
Nothing
    Maybe MemberKey
forall a. Maybe a
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 :: 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 String
name skv
key tt -> IO tr
g = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
PropertyMember
    String
name
    (Tagged tr TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged tr TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged tr TypeId))
    []
    ((tt -> IO tr) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> IO tr
g)
    Maybe UniformFunc
forall a. Maybe a
Nothing
    (MemberKey -> Maybe MemberKey
forall a. a -> Maybe a
Just (MemberKey -> Maybe MemberKey) -> MemberKey -> Maybe MemberKey
forall a b. (a -> b) -> a -> b
$ skv -> MemberKey
forall skv. SignalKeyValue skv => skv -> MemberKey
signalKey skv
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 :: 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 String
name tt -> IO tr
g tt -> tr -> IO ()
s = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
PropertyMember
    String
name
    (Tagged tr TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged tr TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged tr TypeId))
    []
    ((tt -> IO tr) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> IO tr
g)
    (UniformFunc -> Maybe UniformFunc
forall a. a -> Maybe a
Just (UniformFunc -> Maybe UniformFunc)
-> UniformFunc -> Maybe UniformFunc
forall a b. (a -> b) -> a -> b
$ (tt -> tr -> VoidIO) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkSpecialFunc (\tt
a tr
b -> IO () -> VoidIO
VoidIO (IO () -> VoidIO) -> IO () -> VoidIO
forall a b. (a -> b) -> a -> b
$ tt -> tr -> IO ()
s tt
a tr
b))
    Maybe MemberKey
forall a. Maybe a
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 :: 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 String
name skv
key tt -> IO tr
g tt -> tr -> IO ()
s = MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member (MarshalMode tt IGetObjType ())
forall tt.
MemberKind
-> String
-> TypeId
-> [(String, TypeId)]
-> UniformFunc
-> Maybe UniformFunc
-> Maybe MemberKey
-> Member tt
Member MemberKind
PropertyMember
    String
name
    (Tagged tr TypeId -> TypeId
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged tr TypeId
forall t. Marshal t => MTypeCValFunc t
mTypeCVal :: Tagged tr TypeId))
    []
    ((tt -> IO tr) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc tt -> IO tr
g)
    (UniformFunc -> Maybe UniformFunc
forall a. a -> Maybe a
Just (UniformFunc -> Maybe UniformFunc)
-> UniformFunc -> Maybe UniformFunc
forall a b. (a -> b) -> a -> b
$ (tt -> tr -> VoidIO) -> UniformFunc
forall tt ms.
(Marshal tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkSpecialFunc (\tt
a tr
b -> IO () -> VoidIO
VoidIO (IO () -> VoidIO) -> IO () -> VoidIO
forall a b. (a -> b) -> a -> b
$ tt -> tr -> IO ()
s tt
a tr
b))
    (MemberKey -> Maybe MemberKey
forall a. a -> Maybe a
Just (MemberKey -> Maybe MemberKey) -> MemberKey -> Maybe MemberKey
forall a b. (a -> b) -> a -> b
$ skv -> MemberKey
forall skv. SignalKeyValue skv => skv -> MemberKey
signalKey skv
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' :: forall obj tr.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>
String -> (ObjRef obj -> IO tr) -> Member obj
defPropertyConst' = String -> (ObjRef obj -> IO tr) -> Member obj
String -> (ObjRef obj -> IO tr) -> Member (GetObjType (ObjRef obj))
forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,
 CanReturnTo tr ~ Yes) =>
String -> (tt -> IO tr) -> Member (GetObjType tt)
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' :: forall obj tr.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes) =>
String -> (ObjRef obj -> IO tr) -> Member obj
defPropertyRO' = String -> (ObjRef obj -> IO tr) -> Member obj
String -> (ObjRef obj -> IO tr) -> Member (GetObjType (ObjRef obj))
forall tt tr.
(Marshal tt, CanGetFrom tt ~ Yes, Marshal tr,
 CanReturnTo tr ~ Yes) =>
String -> (tt -> IO tr) -> Member (GetObjType tt)
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' :: forall obj tr skv.
(Typeable obj, Marshal tr, CanReturnTo tr ~ Yes,
 SignalKeyValue skv) =>
String -> skv -> (ObjRef obj -> IO tr) -> Member obj
defPropertySigRO' = String -> skv -> (ObjRef obj -> IO tr) -> Member obj
String
-> skv -> (ObjRef obj -> IO tr) -> Member (GetObjType (ObjRef obj))
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

-- | 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' :: 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' = String
-> (ObjRef obj -> IO tr)
-> (ObjRef obj -> tr -> IO ())
-> Member obj
String
-> (ObjRef obj -> IO tr)
-> (ObjRef obj -> tr -> IO ())
-> Member (GetObjType (ObjRef obj))
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

-- | 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' :: 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' = String
-> skv
-> (ObjRef obj -> IO tr)
-> (ObjRef obj -> tr -> IO ())
-> Member obj
String
-> skv
-> (ObjRef obj -> IO tr)
-> (ObjRef obj -> tr -> IO ())
-> Member (GetObjType (ObjRef obj))
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