{-# 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 :: forall a. ErrIO a -> IO ()
runErrIO ErrIO a
m = do
  Maybe a
r <- IO (Maybe a) -> (SomeException -> IO (Maybe a)) -> IO (Maybe a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (ErrIO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT ErrIO a
m) ((SomeException -> IO (Maybe a)) -> IO (Maybe a))
-> (SomeException -> IO (Maybe a)) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ \(SomeException
e :: SomeException) -> do
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Warning: Marshalling error: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
    Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
r) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Warning: Marshalling error (see above for details)."

errIO :: IO a -> ErrIO a
errIO :: forall a. IO a -> ErrIO a
errIO = IO (Maybe a) -> MaybeT IO a
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe a) -> MaybeT IO a)
-> (IO a -> IO (Maybe a)) -> IO a -> MaybeT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe a) -> IO a -> IO (Maybe a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just

tyInt, tyDouble, tyString, tyObject, tyVoid, tyJSValue :: TypeId
tyInt :: TypeId
tyInt     = Int -> TypeId
TypeId Int
2
tyDouble :: TypeId
tyDouble  = Int -> TypeId
TypeId Int
6
tyString :: TypeId
tyString  = Int -> TypeId
TypeId Int
10
tyObject :: TypeId
tyObject  = Int -> TypeId
TypeId Int
39
tyVoid :: TypeId
tyVoid    = Int -> TypeId
TypeId Int
43
tyJSValue :: TypeId
tyJSValue = Int -> TypeId
TypeId Int
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 {
    forall t u v w x y. Marshaller t u v w x y -> MTypeCValFunc t
mTypeCVal_ :: !(MTypeCValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MFromCValFunc t
mFromCVal_ :: !(MFromCValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MToCValFunc t
mToCVal_   :: !(MToCValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MWithCValFunc t
mWithCVal_ :: !(MWithCValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MFromJValFunc t
mFromJVal_ :: !(MFromJValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MWithJValFunc t
mWithJVal_ :: !(MWithJValFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MFromHndlFunc t
mFromHndl_ :: !(MFromHndlFunc t),
    forall t u v w x y. Marshaller t u v w x y -> MToHndlFunc t
mToHndl_   :: !(MToHndlFunc t)
}

mTypeCVal :: forall t. (Marshal t) => MTypeCValFunc t
mTypeCVal :: forall t. Marshal t => MTypeCValFunc t
mTypeCVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MTypeCValFunc t
forall t u v w x y. Marshaller t u v w x y -> MTypeCValFunc t
mTypeCVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mFromCVal :: forall t. (Marshal t) => MFromCValFunc t
mFromCVal :: forall t. Marshal t => MFromCValFunc t
mFromCVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MFromCValFunc t
forall t u v w x y. Marshaller t u v w x y -> MFromCValFunc t
mFromCVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mToCVal :: forall t. (Marshal t) => MToCValFunc t
mToCVal :: forall t. Marshal t => MToCValFunc t
mToCVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MToCValFunc t
forall t u v w x y. Marshaller t u v w x y -> MToCValFunc t
mToCVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mWithCVal :: forall t. (Marshal t) => MWithCValFunc t
mWithCVal :: forall t. Marshal t => MWithCValFunc t
mWithCVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MWithCValFunc t
forall t u v w x y. Marshaller t u v w x y -> MWithCValFunc t
mWithCVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mFromJVal :: forall t. (Marshal t) => MFromJValFunc t
mFromJVal :: forall t. Marshal t => MFromJValFunc t
mFromJVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MFromJValFunc t
forall t u v w x y. Marshaller t u v w x y -> MFromJValFunc t
mFromJVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mWithJVal :: forall t. (Marshal t) => MWithJValFunc t
mWithJVal :: forall t. Marshal t => MWithJValFunc t
mWithJVal = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MWithJValFunc t
forall t u v w x y. Marshaller t u v w x y -> MWithJValFunc t
mWithJVal_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mFromHndl :: forall t. (Marshal t) => MFromHndlFunc t
mFromHndl :: forall t. Marshal t => MFromHndlFunc t
mFromHndl = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MFromHndlFunc t
forall t u v w x y. Marshaller t u v w x y -> MFromHndlFunc t
mFromHndl_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

mToHndl :: forall t. (Marshal t) => MToHndlFunc t
mToHndl :: forall t. Marshal t => MToHndlFunc t
mToHndl = Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
-> MToHndlFunc t
forall t u v w x y. Marshaller t u v w x y -> MToHndlFunc t
mToHndl_ (Marshaller
  t
  (MarshalMode t ICanGetFrom ())
  (MarshalMode t ICanPassTo ())
  (MarshalMode t ICanReturnTo ())
  (MarshalMode t IIsObjType ())
  (MarshalMode t IGetObjType ())
forall t. Marshal t => MarshallerFor t
marshaller :: MarshallerFor t)

unimplFromCVal :: MFromCValFunc t
unimplFromCVal :: forall t. MFromCValFunc t
unimplFromCVal Ptr ()
_ = String -> ErrIO t
forall a. HasCallStack => String -> a
error String
"Type does not support mFromCVal."

unimplToCVal :: MToCValFunc t
unimplToCVal :: forall t. MToCValFunc t
unimplToCVal t
_ Ptr ()
_ = String -> IO ()
forall a. HasCallStack => String -> a
error String
"Type does not support mToCVal."

unimplWithCVal :: MWithCValFunc t
unimplWithCVal :: forall t b. t -> (Ptr () -> IO b) -> IO b
unimplWithCVal t
_ Ptr () -> IO b
_ = String -> IO b
forall a. HasCallStack => String -> a
error String
"Type does not support mWithCVal."

unimplFromJVal :: MFromJValFunc t
unimplFromJVal :: forall t. MFromJValFunc t
unimplFromJVal Strength
_ = String -> HsQMLJValHandle -> ErrIO t
forall a. HasCallStack => String -> a
error String
"Type does not support mFromJVal."

unimplWithJVal :: MWithJValFunc t
unimplWithJVal :: forall t b. t -> (HsQMLJValHandle -> IO b) -> IO b
unimplWithJVal t
_ HsQMLJValHandle -> IO b
_ = String -> IO b
forall a. HasCallStack => String -> a
error String
"Type does not support mWithJVal."

unimplFromHndl :: MFromHndlFunc t
unimplFromHndl :: forall t. MFromHndlFunc t
unimplFromHndl HsQMLObjectHandle
_ = String -> IO t
forall a. HasCallStack => String -> a
error String
"Type does not support mFromHndl."

unimplToHndl :: MToHndlFunc t
unimplToHndl :: forall t. MToHndlFunc t
unimplToHndl t
_ = String -> IO HsQMLObjectHandle
forall a. HasCallStack => String -> a
error String
"Type does not support mToHndl."

jvalFromCVal :: (Marshal t) => MFromCValFunc t
jvalFromCVal :: forall t. Marshal t => MFromCValFunc t
jvalFromCVal = MFromJValFunc t
forall t. Marshal t => MFromJValFunc t
mFromJVal Strength
Strong (HsQMLJValHandle -> ErrIO t)
-> (Ptr () -> HsQMLJValHandle) -> Ptr () -> ErrIO t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr HsQMLJValHandle -> HsQMLJValHandle
HsQMLJValHandle (Ptr HsQMLJValHandle -> HsQMLJValHandle)
-> (Ptr () -> Ptr HsQMLJValHandle) -> Ptr () -> HsQMLJValHandle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> Ptr HsQMLJValHandle
forall a b. Ptr a -> Ptr b
castPtr

jvalToCVal :: (Marshal t) => MToCValFunc t
jvalToCVal :: forall t. Marshal t => MToCValFunc t
jvalToCVal t
val Ptr ()
ptr = t -> (HsQMLJValHandle -> IO ()) -> IO ()
MWithJValFunc t
forall t. Marshal t => MWithJValFunc t
mWithJVal t
val ((HsQMLJValHandle -> IO ()) -> IO ())
-> (HsQMLJValHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \HsQMLJValHandle
jval ->
    HsQMLJValHandle -> HsQMLJValHandle -> IO ()
hsqmlSetJval (Ptr HsQMLJValHandle -> HsQMLJValHandle
HsQMLJValHandle (Ptr HsQMLJValHandle -> HsQMLJValHandle)
-> Ptr HsQMLJValHandle -> HsQMLJValHandle
forall a b. (a -> b) -> a -> b
$ Ptr () -> Ptr HsQMLJValHandle
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
ptr) HsQMLJValHandle
jval

jvalWithCVal :: (Marshal t) => MWithCValFunc t
jvalWithCVal :: forall t. Marshal t => MWithCValFunc t
jvalWithCVal t
val Ptr () -> IO b
f = t -> (HsQMLJValHandle -> IO b) -> IO b
MWithJValFunc t
forall t. Marshal t => MWithJValFunc t
mWithJVal t
val ((HsQMLJValHandle -> IO b) -> IO b)
-> (HsQMLJValHandle -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \(HsQMLJValHandle Ptr HsQMLJValHandle
ptr) ->
    Ptr () -> IO b
f (Ptr () -> IO b) -> Ptr () -> IO b
forall a b. (a -> b) -> a -> b
$ Ptr HsQMLJValHandle -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr HsQMLJValHandle
ptr

instance Marshal () where
    type MarshalMode () c d = ModeRetVoid c
    marshaller :: MarshallerFor ()
marshaller = Marshaller {
        mTypeCVal_ :: MTypeCValFunc ()
mTypeCVal_ = TypeId -> MTypeCValFunc ()
forall {k} (s :: k) b. b -> Tagged s b
Tagged TypeId
tyVoid,
        mFromCVal_ :: MFromCValFunc ()
mFromCVal_ = MFromCValFunc ()
forall t. MFromCValFunc t
unimplFromCVal,
        mToCVal_ :: MToCValFunc ()
mToCVal_ = \()
_ Ptr ()
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (),
        mWithCVal_ :: MWithCValFunc ()
mWithCVal_ = () -> (Ptr () -> IO b) -> IO b
MWithCValFunc ()
forall t b. t -> (Ptr () -> IO b) -> IO b
unimplWithCVal,
        mFromJVal_ :: MFromJValFunc ()
mFromJVal_ = MFromJValFunc ()
forall t. MFromJValFunc t
unimplFromJVal,
        mWithJVal_ :: MWithJValFunc ()
mWithJVal_ = () -> (HsQMLJValHandle -> IO b) -> IO b
MWithJValFunc ()
forall t b. t -> (HsQMLJValHandle -> IO b) -> IO b
unimplWithJVal,
        mFromHndl_ :: MFromHndlFunc ()
mFromHndl_ = MFromHndlFunc ()
forall t. MFromHndlFunc t
unimplFromHndl,
        mToHndl_ :: MToHndlFunc ()
mToHndl_ = MToHndlFunc ()
forall t. MToHndlFunc t
unimplToHndl}