{-# LANGUAGE
ScopedTypeVariables,
TypeFamilies,
FlexibleInstances
#-}
module Graphics.QML.Marshal (
Marshal (
type MarshalMode,
marshaller),
ModeBidi,
ModeFrom,
ModeTo,
ModeRetVoid,
ModeObjBidi,
ModeObjFrom,
ModeObjTo,
Yes,
CanGetFrom,
ICanGetFrom,
CanPassTo,
ICanPassTo,
CanReturnTo,
ICanReturnTo,
IsObjType,
IIsObjType,
GetObjType,
IGetObjType,
Marshaller,
Ignored (
Ignored),
bidiMarshallerIO,
bidiMarshaller,
fromMarshallerIO,
fromMarshaller,
toMarshallerIO,
toMarshaller
) where
import Graphics.QML.Internal.BindPrim
import Graphics.QML.Internal.Marshal
import Graphics.QML.Internal.Types
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Tagged
import Data.Int
import Data.Text (Text)
import qualified Data.Text.Foreign as T
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
instance Marshal Bool where
type MarshalMode Bool c d = ModeBidi c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyJSValue,
mFromCVal_ = jvalFromCVal,
mToCVal_ = jvalToCVal,
mWithCVal_ = jvalWithCVal,
mFromJVal_ = \s ptr ->
MaybeT $ fromJVal s hsqmlIsJvalBool hsqmlGetJvalBool ptr,
mWithJVal_ = \bool f ->
withJVal hsqmlInitJvalBool bool f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance Marshal Int32 where
type MarshalMode Int32 c d = ModeBidi c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyInt,
mFromCVal_ = \ptr ->
errIO $ peek (castPtr ptr :: Ptr CInt) >>= return . fromIntegral,
mToCVal_ = \int ptr ->
poke (castPtr ptr :: Ptr CInt) (fromIntegral int),
mWithCVal_ = \int f ->
alloca $ \(ptr :: Ptr CInt) ->
mToCVal int (castPtr ptr) >> f (castPtr ptr),
mFromJVal_ = \s ptr ->
MaybeT $ fromJVal s hsqmlIsJvalNumber (
fmap fromIntegral . hsqmlGetJvalInt) ptr,
mWithJVal_ = \int f ->
withJVal hsqmlInitJvalInt (fromIntegral int) f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance Marshal Int where
type MarshalMode Int c d = ModeBidi c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyInt,
mFromCVal_ = fmap (fromIntegral :: Int32 -> Int) . mFromCVal,
mToCVal_ = \int ptr -> mToCVal (fromIntegral int :: Int32) ptr,
mWithCVal_ = \int f -> mWithCVal (fromIntegral int :: Int32) f,
mFromJVal_ = \s -> fmap (fromIntegral :: Int32 -> Int) . mFromJVal s,
mWithJVal_ = \int f -> mWithJVal (fromIntegral int :: Int32) f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance Marshal Double where
type MarshalMode Double c d = ModeBidi c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyDouble,
mFromCVal_ = \ptr ->
errIO $ peek (castPtr ptr :: Ptr CDouble) >>= return . realToFrac,
mToCVal_ = \num ptr ->
poke (castPtr ptr :: Ptr CDouble) (realToFrac num),
mWithCVal_ = \num f ->
alloca $ \(ptr :: Ptr CDouble) ->
mToCVal num (castPtr ptr) >> f (castPtr ptr),
mFromJVal_ = \s ptr ->
MaybeT $ fromJVal s hsqmlIsJvalNumber (
fmap realToFrac . hsqmlGetJvalDouble) ptr,
mWithJVal_ = \num f ->
withJVal hsqmlInitJvalDouble (realToFrac num) f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance Marshal Text where
type MarshalMode Text c d = ModeBidi c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyString,
mFromCVal_ = \ptr -> errIO $ do
pair <- alloca (\bufPtr -> do
len <- hsqmlReadString (
HsQMLStringHandle $ castPtr ptr) bufPtr
buf <- peek bufPtr
return (castPtr buf, fromIntegral len))
uncurry T.fromPtr pair,
mToCVal_ = \txt ptr -> do
array <- hsqmlWriteString
(T.lengthWord16 txt) (HsQMLStringHandle $ castPtr ptr)
T.unsafeCopyToPtr txt (castPtr array),
mWithCVal_ = \txt f ->
withStrHndl $ \(HsQMLStringHandle ptr) -> do
mToCVal txt $ castPtr ptr
f $ castPtr ptr,
mFromJVal_ = \s jval ->
MaybeT $ withStrHndl $ \sHndl -> runMaybeT $ do
MaybeT $ fromJVal s hsqmlIsJvalString (
flip hsqmlGetJvalString sHndl) jval
let (HsQMLStringHandle ptr) = sHndl
mFromCVal $ castPtr ptr,
mWithJVal_ = \txt f ->
mWithCVal txt $ \ptr -> withJVal hsqmlInitJvalString (
HsQMLStringHandle $ castPtr ptr) f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance (Marshal a) => Marshal (Maybe a) where
type MarshalMode (Maybe a) ICanGetFrom d = MarshalMode a ICanGetFrom d
type MarshalMode (Maybe a) ICanPassTo d = MarshalMode a ICanPassTo d
type MarshalMode (Maybe a) ICanReturnTo d = MarshalMode a ICanReturnTo d
type MarshalMode (Maybe a) IIsObjType d = No
type MarshalMode (Maybe a) IGetObjType d = No
marshaller = Marshaller {
mTypeCVal_ = Tagged tyJSValue,
mFromCVal_ = jvalFromCVal,
mToCVal_ = jvalToCVal,
mWithCVal_ = jvalWithCVal,
mFromJVal_ = \_ jval -> errIO $ runMaybeT $ mFromJVal Weak jval,
mWithJVal_ = \val f ->
case val of
Just val' -> mWithJVal val' f
Nothing -> withJVal hsqmlInitJvalNull False f,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
instance (Marshal a) => Marshal [a] where
type MarshalMode [a] ICanGetFrom d = MarshalMode a ICanGetFrom d
type MarshalMode [a] ICanPassTo d = MarshalMode a ICanPassTo d
type MarshalMode [a] ICanReturnTo d = MarshalMode a ICanReturnTo d
type MarshalMode [a] IIsObjType d = No
type MarshalMode [a] IGetObjType d = No
marshaller = Marshaller {
mTypeCVal_ = Tagged tyJSValue,
mFromCVal_ = jvalFromCVal,
mToCVal_ = jvalToCVal,
mWithCVal_ = jvalWithCVal,
mFromJVal_ = \s jval -> MaybeT $ do
len <- hsqmlGetJvalArrayLength jval
withJVal hsqmlInitJvalNull True $ \tmp ->
runMaybeT $ forM [0..len-1] $ \i -> do
errIO $ hsqmlJvalArrayGet jval i tmp
mFromJVal s tmp,
mWithJVal_ = \vs f ->
withJVal hsqmlInitJvalArray (length vs) $ \jval -> do
forM_ (zip [0..] vs) $ uncurry $ \i val ->
mWithJVal val $ \jval' ->
hsqmlJvalArraySet jval i jval'
f jval,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
data Ignored = Ignored
instance Marshal Ignored where
type MarshalMode Ignored c d = ModeFrom c
marshaller = Marshaller {
mTypeCVal_ = Tagged tyJSValue,
mFromCVal_ = jvalFromCVal,
mToCVal_ = unimplToCVal,
mWithCVal_ = unimplWithCVal,
mFromJVal_ = \_ _ -> MaybeT . return $ Just Ignored,
mWithJVal_ = unimplWithJVal,
mFromHndl_ = unimplFromHndl,
mToHndl_ = unimplToHndl}
type BidiMarshaller a b = Marshaller b
(MarshalMode a ICanGetFrom ())
(MarshalMode a ICanPassTo ())
(MarshalMode a ICanReturnTo ())
(MarshalMode a IIsObjType ())
(MarshalMode a IGetObjType ())
bidiMarshallerIO ::
forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>
(a -> IO b) -> (b -> IO a) -> BidiMarshaller a b
bidiMarshallerIO fromFn toFn = Marshaller {
mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),
mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr,
mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val,
mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,
mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr,
mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,
mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,
mToHndl_ = \val -> mToHndl =<< toFn val}
bidiMarshaller ::
forall a b. (Marshal a, CanGetFrom a ~ Yes, CanPassTo a ~ Yes) =>
(a -> b) -> (b -> a) -> BidiMarshaller a b
bidiMarshaller fromFn toFn =
bidiMarshallerIO (return . fromFn) (return . toFn)
type FromMarshaller a b = Marshaller b
(MarshalMode a ICanGetFrom ())
No
No
(MarshalMode a IIsObjType ())
(MarshalMode a IGetObjType ())
fromMarshallerIO ::
forall a b. (Marshal a, CanGetFrom a ~ Yes) =>
(a -> IO b) -> FromMarshaller a b
fromMarshallerIO fromFn = Marshaller {
mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),
mFromCVal_ = \ptr -> (errIO . fromFn) =<< mFromCVal ptr,
mToCVal_ = unimplToCVal,
mWithCVal_ = unimplWithCVal,
mFromJVal_ = \s ptr -> (errIO . fromFn) =<< mFromJVal s ptr,
mWithJVal_ = unimplWithJVal,
mFromHndl_ = \hndl -> fromFn =<< mFromHndl hndl,
mToHndl_ = unimplToHndl}
fromMarshaller ::
forall a b. (Marshal a, CanGetFrom a ~ Yes) =>
(a -> b) -> FromMarshaller a b
fromMarshaller fromFn = fromMarshallerIO (return . fromFn)
type ToMarshaller a b = Marshaller b
No
(MarshalMode a ICanPassTo ())
(MarshalMode a ICanReturnTo ())
(MarshalMode a IIsObjType ())
(MarshalMode a IGetObjType ())
toMarshallerIO ::
forall a b. (Marshal a, CanPassTo a ~ Yes) =>
(b -> IO a) -> ToMarshaller a b
toMarshallerIO toFn = Marshaller {
mTypeCVal_ = retag (mTypeCVal :: Tagged a TypeId),
mFromCVal_ = unimplFromCVal,
mToCVal_ = \val ptr -> flip mToCVal ptr =<< toFn val,
mWithCVal_ = \val f -> flip mWithCVal f =<< toFn val,
mFromJVal_ = unimplFromJVal,
mWithJVal_ = \val f -> flip mWithJVal f =<< toFn val,
mFromHndl_ = unimplFromHndl,
mToHndl_ = \val -> mToHndl =<< toFn val}
toMarshaller ::
forall a b. (Marshal a, CanPassTo a ~ Yes) =>
(b -> a) -> ToMarshaller a b
toMarshaller toFn = toMarshallerIO (return . toFn)