{-# LANGUAGE
ScopedTypeVariables,
TypeFamilies,
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.Trans.Maybe
import Data.Maybe
import Data.Tagged
import Foreign.Ptr
import System.IO
type ErrIO a = MaybeT IO a
runErrIO :: ErrIO a -> IO ()
runErrIO m = do
r <- catch (runMaybeT m) $ \(SomeException _) -> return Nothing
if isNothing r
then hPutStrLn stderr "Warning: Marshalling error."
else return ()
errIO :: IO a -> ErrIO a
errIO = MaybeT . fmap Just
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)
class Marshal t where
type MarshalMode t c d
marshaller :: MarshallerFor t
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
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
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
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
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
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
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
data Yes
data No
type CanGetFrom t = MarshalMode t ICanGetFrom ()
data ICanGetFrom
type CanPassTo t = MarshalMode t ICanPassTo ()
data ICanPassTo
type CanReturnTo t = MarshalMode t ICanReturnTo ()
data ICanReturnTo
type IsObjType t = MarshalMode t IIsObjType ()
data IIsObjType
type GetObjType t = MarshalMode t IGetObjType ()
data IGetObjType
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)
}
mTypeCVal :: forall t. (Marshal t) => MTypeCValFunc t
mTypeCVal = mTypeCVal_ (marshaller :: MarshallerFor t)
mFromCVal :: forall t. (Marshal t) => MFromCValFunc t
mFromCVal = mFromCVal_ (marshaller :: MarshallerFor t)
mToCVal :: forall t. (Marshal t) => MToCValFunc t
mToCVal = mToCVal_ (marshaller :: MarshallerFor t)
mWithCVal :: forall t. (Marshal t) => MWithCValFunc t
mWithCVal = mWithCVal_ (marshaller :: MarshallerFor t)
mFromJVal :: forall t. (Marshal t) => MFromJValFunc t
mFromJVal = mFromJVal_ (marshaller :: MarshallerFor t)
mWithJVal :: forall t. (Marshal t) => MWithJValFunc t
mWithJVal = mWithJVal_ (marshaller :: MarshallerFor t)
mFromHndl :: forall t. (Marshal t) => MFromHndlFunc t
mFromHndl = mFromHndl_ (marshaller :: MarshallerFor t)
mToHndl :: forall t. (Marshal t) => MToHndlFunc t
mToHndl = mToHndl_ (marshaller :: MarshallerFor t)
unimplFromCVal :: MFromCValFunc t
unimplFromCVal _ = error "Type does not support mFromCVal."
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 () c d = ModeRetVoid c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyVoid,
mFromCVal_ = unimplFromCVal,
mToCVal_ = \_ _ -> return (),
mWithCVal_ = unimplWithCVal,
mFromJVal_ = unimplFromJVal,
mWithJVal_ = unimplWithJVal,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}