Marshal.hs

{-# LANGUAGE
    ScopedTypeVariables,
    TypeFamilies,
    FlexibleInstances
  #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Type classs and instances for marshalling values between Haskell and QML.
module Graphics.QML.Marshal (
  -- * Marshalling Type-class
  Marshal (
    type MarshalMode,
    marshaller),
  ModeBidi,
  ModeFrom,
  ModeTo,
  ModeRetVoid,
  ModeObjBidi,
  ModeObjFrom,
  ModeObjTo,
  Yes,
  CanGetFrom,
  ICanGetFrom,
  CanPassTo,
  ICanPassTo,
  CanReturnTo,
  ICanReturnTo,
  IsObjType,
  IIsObjType,
  GetObjType,
  IGetObjType,
  Marshaller,

  -- * Data Types
  Ignored (
    Ignored),

  -- * Custom Marshallers
  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 qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BSU
import Data.Tagged
import Data.Int
import Data.Text (Text)
import qualified Data.Text.Encoding as TE
import Foreign.C.Types
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr
import Foreign.Storable

--
-- Boolean built-in type
--

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}

--
-- Int32/int built-in type
--

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}

--
-- Double/double built-in type
--

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}

--
-- Text/QString built-in type
--


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 (buf, len))
            let (buf, len) = pair
            bs <- BS.packCStringLen (castPtr buf, len * 2)
            return $ TE.decodeUtf16LE bs,
        mToCVal_ = \txt ptr -> do
            let bs = TE.encodeUtf16LE txt
                ucs2Length = BS.length bs `div` 2
            array <- hsqmlWriteString ucs2Length (HsQMLStringHandle $ castPtr ptr)
            BSU.unsafeUseAsCStringLen bs (\(bsp, bslen) -> copyBytes (castPtr array) bsp bslen),
        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}

--
-- Maybe
--

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}

--
-- List
--

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}

--
-- Ignored
--

-- | Represents an argument whose value is ignored.

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 ())

-- | Provides a bidirectional 'Marshaller' which allows you to define an
-- instance of 'Marshal' for your own type @b@ in terms of another marshallable
-- type @a@. Type @b@ should have a 'MarshalMode' of 'ModeObjBidi' or
-- 'ModeBidi' depending on whether @a@ was an object type or not.
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}

-- | Variant of 'bidiMarshallerIO' where the conversion functions between types
-- @a@ and @b@ do not live in the IO monad.
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 ())

-- | Provides a "from" 'Marshaller' which allows you to define an instance of
-- 'Marshal' for your own type @b@ in terms of another marshallable type @a@.
-- Type @b@ should have a 'MarshalMode' of 'ModeObjFrom' or 'ModeFrom'
-- depending on whether @a@ was an object type or not.
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}

-- | Variant of 'fromMarshallerIO' where the conversion function between types
-- @a@ and @b@ does not live in the IO monad.
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 ())

-- | Provides a "to" 'Marshaller' which allows you to define an instance of
-- 'Marshal' for your own type @b@ in terms of another marshallable type @a@.
-- Type @b@ should have a 'MarshalMode' of 'ModeObjTo' or 'ModeTo'
-- depending on whether @a@ was an object type or not.
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}

-- | Variant of 'toMarshallerIO' where the conversion function between types
-- @a@ and @b@ does not live in the IO monad.
toMarshaller ::
    forall a b. (Marshal a, CanPassTo a ~ Yes) =>
    (b -> a) -> ToMarshaller a b
toMarshaller toFn = toMarshallerIO (return . toFn)