module Graphics.QML.Objects (
Object (
classDef),
ClassDef,
Member,
defClass,
defMethod,
MethodSuffix,
defPropertyRO,
defPropertyRW,
ObjRef,
newObject,
fromObjRef,
objectInMarshaller,
MarshalThis (
type ThisObj,
mThis),
objectThisMarshaller
) where
import Graphics.QML.Internal.Marshal
import Graphics.QML.Internal.Objects
import Graphics.QML.Internal.Engine
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State
import Data.Bits
import Data.Char
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Tagged
import Data.Typeable
import Foreign.C.Types
import Foreign.C.String
import Foreign.Ptr
import Foreign.Storable
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import System.IO.Unsafe
import Numeric
class (Object (ThisObj tt)) => MarshalThis tt where
type ThisObj tt
mThis :: ThisMarshaller tt
data ThisMarshaller tt = ThisMarshaller {
mThisFuncFld :: Ptr () -> IO tt
}
mThisFunc :: (MarshalThis tt) => Ptr () -> IO tt
mThisFunc = mThisFuncFld mThis
instance (Object tt) => MarshalOut (ObjRef tt) where
mOutFunc ptr obj = do
objPtr <- hsqmlObjectGetPointer $ objHndl obj
poke (castPtr ptr) objPtr
mOutAlloc obj f =
alloca $ \(ptr :: Ptr (Ptr ())) ->
mOutFunc (castPtr ptr) obj >> f (castPtr ptr)
instance (Object tt) => MarshalIn (ObjRef tt) where
mIn = InMarshaller {
mInFuncFld = \ptr -> MaybeT $ do
objPtr <- peek (castPtr ptr)
hndl <- hsqmlGetObjectHandle objPtr $
Just $ classHndl (classDefCAF :: ClassDef tt)
return $ if isNullObjectHandle hndl
then Nothing else Just $ ObjRef hndl,
mIOTypeFld = Tagged $ TypeName "QObject*"
}
instance (Object tt) => MarshalThis (ObjRef tt) where
type ThisObj (ObjRef tt) = tt
mThis = ThisMarshaller {
mThisFuncFld = \ptr -> do
hndl <- hsqmlGetObjectHandle ptr Nothing
return $ ObjRef hndl
}
retagType :: Tagged (ObjRef tt) TypeName -> Tagged tt TypeName
retagType = retag
objectInMarshaller :: (Object tt) => InMarshaller tt
objectInMarshaller =
InMarshaller {
mInFuncFld = fmap fromObjRef . mInFunc,
mIOTypeFld = retagType mIOType
}
objectThisMarshaller :: (Object tt, (ThisObj tt) ~ tt) => ThisMarshaller tt
objectThisMarshaller =
ThisMarshaller {
mThisFuncFld = fmap fromObjRef . mThisFunc
}
newObject :: forall tt. (Object tt) => tt -> IO (ObjRef tt)
newObject obj = do
hndl <- hsqmlCreateObject obj $ classHndl (classDefCAF :: ClassDef tt)
return $ ObjRef hndl
fromObjRef :: ObjRef tt -> tt
fromObjRef =
unsafePerformIO . hsqmlObjectGetHaskell . objHndl
class (Typeable tt) => Object tt where
classDef :: ClassDef tt
classDefCAF :: (Object tt) => ClassDef tt
classDefCAF = classDef
data ClassDef tt = ClassDef {
classType :: TypeName,
classHndl :: HsQMLClassHandle
}
defClass :: forall tt. (Object tt) => [Member tt] -> ClassDef tt
defClass ms = unsafePerformIO $ do
let typ = typeOf (undefined :: tt)
con = typeRepTyCon typ
name = showString (tyConModule con) $ showChar '.' $ tyConName con
id <- hsqmlGetNextClassId
createClass (showString name $ showChar '_' $ showInt id "") ms
createClass :: forall tt. (Object tt) =>
String -> [Member tt] -> IO (ClassDef tt)
createClass name ms = do
let methods = methodMembers ms
properties = propertyMembers ms
(MOCOutput metaData metaStrData) = compileClass name methods properties
metaDataPtr <- newArray metaData
metaStrDataPtr <- newArray metaStrData
methodsPtr <- mapM (marshalFunc . methodFunc) methods >>= newArray
pReads <- mapM (marshalFunc . propertyReadFunc) properties
pWrites <- mapM (fromMaybe (return nullFunPtr) . fmap marshalFunc .
propertyWriteFunc) properties
propertiesPtr <- newArray $ interleave pReads pWrites
hsqmlInit
hndl <- hsqmlCreateClass metaDataPtr metaStrDataPtr methodsPtr propertiesPtr
return $ case hndl of
Just hndl' -> ClassDef (TypeName name) hndl'
Nothing -> error ("Failed to create QML class '"++name++"'.")
interleave :: [a] -> [a] -> [a]
interleave [] ys = ys
interleave (x:xs) ys = x : ys `interleave` xs
data Member tt
= MethodMember (Method tt)
| PropertyMember (Property tt)
methodMembers :: [Member tt] -> [Method tt]
methodMembers = mapMaybe f
where f (MethodMember m) = Just m
f _ = Nothing
propertyMembers :: [Member tt] -> [Property tt]
propertyMembers = mapMaybe f
where f (PropertyMember m) = Just m
f _ = Nothing
data Method tt = Method {
methodName :: String,
methodTypes :: [TypeName],
methodFunc :: UniformFunc
}
data CrudeMethodTypes = CrudeMethodTypes {
methodParamTypes :: [TypeName],
methodReturnType :: TypeName
}
crudeTypesToList :: CrudeMethodTypes -> [TypeName]
crudeTypesToList (CrudeMethodTypes p r) = r:p
class MethodSuffix a where
mkMethodFunc :: Int -> a -> Ptr (Ptr ()) -> ErrIO ()
mkMethodTypes :: Tagged a CrudeMethodTypes
instance (MarshalIn a, MethodSuffix b) => MethodSuffix (a -> b) where
mkMethodFunc n f pv = do
ptr <- errIO $ peekElemOff pv n
val <- mInFunc ptr
mkMethodFunc (n+1) (f val) pv
return ()
mkMethodTypes =
let (CrudeMethodTypes p r) =
untag (mkMethodTypes :: Tagged b CrudeMethodTypes)
ty = untag (mIOType :: Tagged a TypeName)
in Tagged $ CrudeMethodTypes (ty:p) r
instance (MarshalOut a) => MethodSuffix (IO a) where
mkMethodFunc _ f pv = errIO $ do
ptr <- peekElemOff pv 0
val <- f
if nullPtr == ptr
then return ()
else mOutFunc ptr val
mkMethodTypes =
let ty = untag (mIOType :: Tagged a TypeName)
in Tagged $ CrudeMethodTypes [] ty
mkUniformFunc :: forall tt ms. (MarshalThis tt, MethodSuffix ms) =>
(tt -> ms) -> UniformFunc
mkUniformFunc f = \pt pv -> do
this <- mThisFunc pt
runErrIO $ mkMethodFunc 1 (f this) pv
defMethod ::
forall tt ms. (MarshalThis tt, MethodSuffix ms) =>
String -> (tt -> ms) -> Member (ThisObj tt)
defMethod name f = MethodMember $ Method name
(crudeTypesToList $ untag (mkMethodTypes :: Tagged ms CrudeMethodTypes))
(mkUniformFunc f)
data Property tt = Property {
propertyName :: String,
propertyType :: TypeName,
propertyReadFunc :: UniformFunc,
propertyWriteFunc :: Maybe UniformFunc
}
defPropertyRO ::
forall tt tr. (MarshalThis tt, MarshalOut tr) =>
String -> (tt -> IO tr) -> Member (ThisObj tt)
defPropertyRO name g = PropertyMember $ Property name
(untag (mIOType :: Tagged tr TypeName))
(mkUniformFunc g)
Nothing
defPropertyRW ::
forall tt tr. (MarshalThis tt, MarshalOut tr) =>
String -> (tt -> IO tr) -> (tt -> tr -> IO ()) -> Member (ThisObj tt)
defPropertyRW name g s = PropertyMember $ Property name
(untag (mIOType :: Tagged tr TypeName))
(mkUniformFunc g)
(Just $ mkUniformFunc s)
data MOCState = MOCState {
mData :: [CUInt],
mDataLen :: Int,
mDataMethodsIdx :: Maybe Int,
mDataPropsIdx :: Maybe Int,
mStrData :: [CChar],
mStrDataLen :: Int,
mStrDataMap :: Map String CUInt
} deriving Show
data MOCOutput = MOCOutput [CUInt] [CChar]
newMOCState :: MOCState
newMOCState = MOCState [] 0 Nothing Nothing [] 0 Map.empty
writeInt :: CUInt -> State MOCState ()
writeInt int = do
state <- get
let md = mData state
mdLen = mDataLen state
put $ state {mData = int:md, mDataLen = mdLen+1}
return ()
writeString :: String -> State MOCState ()
writeString str = do
state <- get
let msd = mStrData state
msdLen = mStrDataLen state
msdMap = mStrDataMap state
case (Map.lookup str msdMap) of
Just idx -> writeInt idx
Nothing -> do
let idx = fromIntegral msdLen
msd' = 0 : (map castCharToCChar (reverse str) ++ msd)
msdLen' = msdLen + length str + 1
msdMap' = Map.insert str idx msdMap
put $ state {
mStrData = msd',
mStrDataLen = msdLen',
mStrDataMap = msdMap'}
writeInt idx
writeMethod :: Method tt -> State MOCState ()
writeMethod m = do
idx <- get >>= return . mDataLen
writeString $ methodSignature m
writeString $ methodParameters m
writeString $ typeName $ head $ methodTypes m
writeString ""
writeInt (mfAccessPublic .|. mfMethodScriptable)
state <- get
put $ state {mDataMethodsIdx = mplus (mDataMethodsIdx state) (Just idx)}
return ()
writeProperty :: Property tt -> State MOCState ()
writeProperty p = do
idx <- get >>= return . mDataLen
writeString $ propertyName p
writeString $ typeName $ propertyType p
writeInt (pfReadable .|. pfScriptable .|.
if (isJust $ propertyWriteFunc p) then pfWritable else 0)
state <- get
put $ state {mDataPropsIdx = mplus (mDataPropsIdx state) (Just idx)}
return ()
compileClass :: String -> [Method tt] -> [Property tt] -> MOCOutput
compileClass name ms ps =
let enc = flip execState newMOCState $ do
writeInt 5
writeString name
writeInt 0 >> writeInt 0
writeInt $ fromIntegral $ length ms
writeInt $ fromIntegral $
fromMaybe 0 $ mDataMethodsIdx enc
writeInt $ fromIntegral $ length ps
writeInt $ fromIntegral $
fromMaybe 0 $ mDataPropsIdx enc
writeInt 0 >> writeInt 0
writeInt 0 >> writeInt 0
writeInt 0
writeInt 0
mapM_ writeMethod ms
mapM_ writeProperty ps
writeInt 0
in MOCOutput (reverse $ mData enc) (reverse $ mStrData enc)
foldr0 :: (a -> a -> a) -> a -> [a] -> a
foldr0 _ x [] = x
foldr0 f _ xs = foldr1 f xs
methodSignature :: Method tt -> String
methodSignature method =
let paramTypes = tail $ methodTypes method
in (showString (methodName method) . showChar '(' .
foldr0 (\l r -> l . showChar ',' . r) id
(map (showString . typeName) paramTypes) . showChar ')') ""
methodParameters :: Method tt -> String
methodParameters method =
replicate (flip () 2 $ length $ methodTypes method) ','