Marshal.hs

{-# 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 (when)
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) $ \(e :: SomeException) -> do
    hPutStrLn stderr $ "Warning: Marshalling error: " ++ show e
    return Nothing
  when (isNothing r) $
    hPutStrLn stderr "Warning: Marshalling error (see above for details)."

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)

-- | The class 'Marshal' allows Haskell values to be marshalled to and from the
-- QML environment.
class Marshal t where
    -- | The 'MarshalMode' associated type family specifies the marshalling
    -- capabilities offered by the instance. @c@ indicates the capability being
    -- queried. @d@ is dummy parameter which allows certain instances to type
    -- check.
    type MarshalMode t c d
    -- | Yields the 'Marshaller' for the type @t@.
    marshaller :: MarshallerFor t

-- | 'MarshalMode' for non-object types with bidirectional marshalling.
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

-- | 'MarshalMode' for non-object types with from-only marshalling.
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

-- | 'MarshalMode' for non-object types with to-only marshalling.
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

-- | 'MarshalMode' for void in method returns.
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

-- | 'MarshalMode' for object types with bidirectional marshalling.
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

-- | 'MarshalMode' for object types with from-only marshalling.
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

-- | 'MarshalMode' for object types with to-only marshalling.
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

-- | Type value indicating a capability is supported.
data Yes

-- | Type value indicating a capability is not supported.
data No

-- | Type function equal to 'Yes' if the marshallable type @t@ supports being
-- received from QML.
type CanGetFrom t = MarshalMode t ICanGetFrom ()

-- | Type index into 'MarshalMode' for querying if the mode supports receiving
-- values from QML.
data ICanGetFrom

-- | Type function equal to 'Yes' if the marshallable type @t@ supports being
-- passed to QML.
type CanPassTo t = MarshalMode t ICanPassTo ()

-- | Type index into 'MarshalMode' for querying if the mode supports passing
-- values to QML.
data ICanPassTo

-- | Type function equal to 'Yes' if the marshallable type @t@ supports being
-- returned to QML.
type CanReturnTo t = MarshalMode t ICanReturnTo ()

-- | Type index into 'MarshalMode' for querying if the mode supports returning
-- values to QML.
data ICanReturnTo

-- | Type function equal to 'Yes' if the marshallable type @t@ is an object.
type IsObjType t = MarshalMode t IIsObjType ()

-- | Type index into 'MarshalMode' for querying if the mode supports an object
-- type.
data IIsObjType

-- | Type function which returns the type encapsulated by the object handles
-- used by the marshallable type @t@.
type GetObjType t = MarshalMode t IGetObjType ()

-- | Type index into 'MarshalMode' for querying the type encapsulated by the
-- mode's object handles.
data IGetObjType

-- | Encapsulates the functionality to needed to implement an instance of
-- 'Marshal' so that such instances can be defined without access to
-- implementation details.
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}