-- | Utilities for writing language bindings transferring complex parameters.
-- Encoding & decoding parameters via MessagePack.
module Graphics.Text.Font.Choose.Internal.FFI(
        unpackWithErr, withMessageIO, withMessage, fromMessage, fromMessage0,
        fromMessageIO0, withCString', peekCString', withForeignPtr'
    ) where

import Data.MessagePack (MessagePack(fromObject), pack, unpack, Object(ObjectStr))
import Foreign.C.String (CString, withCString, peekCString)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca, free)
import Data.Tuple (swap)
import Graphics.Text.Font.Choose.Result (throwNull, FcException)
import Data.Maybe (fromJust)
import Text.Read (readMaybe)
import Control.Exception (throw)

import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackMallocCStringLen)
import Data.ByteString.Lazy (toStrict, fromStrict, ByteString)
import qualified Data.Text as Txt
import System.IO.Unsafe (unsafePerformIO)

-- | Decode a MessagePack packet whilst throwing textually-specified exceptions.
unpackWithErr :: MessagePack a => ByteString -> Maybe a
unpackWithErr :: forall a. MessagePack a => ByteString -> Maybe a
unpackWithErr ByteString
bs = case ByteString -> Maybe Object
forall a. MessagePack a => ByteString -> Maybe a
unpack ByteString
bs of
    Just (ObjectStr Text
err) |
        Just FcException
x <- (String -> Maybe FcException
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe FcException) -> String -> Maybe FcException
forall a b. (a -> b) -> a -> b
$ Text -> String
Txt.unpack Text
err :: Maybe FcException) -> FcException -> Maybe a
forall a e. Exception e => e -> a
throw FcException
x
    Just Object
x -> Object -> Maybe a
forall a. MessagePack a => Object -> Maybe a
fromObject Object
x
    Maybe Object
Nothing -> Maybe a
forall a. Maybe a
Nothing

-- | Encode data via MessagePack to pass to an impure C function.
withMessageIO :: MessagePack a => (CString -> Int -> IO b) -> a -> IO b
withMessageIO :: forall a b. MessagePack a => (CString -> Int -> IO b) -> a -> IO b
withMessageIO CString -> Int -> IO b
cb a
a = ByteString -> (CStringLen -> IO b) -> IO b
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen (ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. MessagePack a => a -> ByteString
pack a
a) ((CString -> Int -> IO b) -> CStringLen -> IO b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CString -> Int -> IO b
cb)

-- | Encode data via MessagePack to pass to a pure C function.
withMessage :: MessagePack a => (CString -> Int -> b) -> a -> b
withMessage :: forall a b. MessagePack a => (CString -> Int -> b) -> a -> b
withMessage CString -> Int -> b
inner a
arg = IO b -> b
forall a. IO a -> a
unsafePerformIO (IO b -> b) -> IO b -> b
forall a b. (a -> b) -> a -> b
$ (CString -> Int -> IO b) -> a -> IO b
forall a b. MessagePack a => (CString -> Int -> IO b) -> a -> IO b
withMessageIO (\CString
x -> b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (Int -> b) -> Int -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Int -> b
inner CString
x) a
arg

-- | Decode data via MessagePack returned from a pure C function.
fromMessage :: MessagePack a => (Ptr Int -> CString) -> Maybe a
fromMessage :: forall a. MessagePack a => (Ptr Int -> CString) -> Maybe a
fromMessage Ptr Int -> CString
inner = ByteString -> Maybe a
forall a. MessagePack a => ByteString -> Maybe a
unpackWithErr (ByteString -> Maybe a) -> ByteString -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
    CStringLen -> IO ByteString
unsafePackMallocCStringLen (CStringLen -> IO ByteString)
-> ((Int, CString) -> CStringLen)
-> (Int, CString)
-> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, CString) -> CStringLen
forall a b. (a, b) -> (b, a)
swap ((Int, CString) -> IO ByteString)
-> IO (Int, CString) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Ptr Int -> IO CString) -> IO (Int, CString)
forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
withPtr (CString -> IO CString
forall a. Ptr a -> IO (Ptr a)
throwNull (CString -> IO CString)
-> (Ptr Int -> CString) -> Ptr Int -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Int -> CString
inner)

-- | Decode data via MessagePack returned from a pure C function,
-- throwing exceptions upon failed decodes.
fromMessage0 :: MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 :: forall a. MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a)
-> ((Ptr Int -> CString) -> Maybe a) -> (Ptr Int -> CString) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr Int -> CString) -> Maybe a
forall a. MessagePack a => (Ptr Int -> CString) -> Maybe a
fromMessage

-- | Decode data via MessagePack returned from an impure C function.
fromMessageIO :: MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)
fromMessageIO :: forall a. MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)
fromMessageIO Ptr Int -> IO CString
inner = do
    (Int
a, CString
b) <- (Ptr Int -> IO CString) -> IO (Int, CString)
forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
withPtr ((Ptr Int -> IO CString) -> IO (Int, CString))
-> (Ptr Int -> IO CString) -> IO (Int, CString)
forall a b. (a -> b) -> a -> b
$ \Ptr Int
ptr -> do
        CString -> IO CString
forall a. Ptr a -> IO (Ptr a)
throwNull (CString -> IO CString) -> IO CString -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr Int -> IO CString
inner Ptr Int
ptr
    ByteString
bs <- CStringLen -> IO ByteString
unsafePackMallocCStringLen (CString
b, Int
a)
    Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe a
forall a. MessagePack a => ByteString -> Maybe a
unpackWithErr (ByteString -> Maybe a) -> ByteString -> Maybe a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
bs

-- | Decode data via MessagePack returned from an impure C function,
-- throwing exceptions upon failed decodes.
fromMessageIO0 :: MessagePack a => (Ptr Int -> IO CString) -> IO a
fromMessageIO0 :: forall a. MessagePack a => (Ptr Int -> IO CString) -> IO a
fromMessageIO0 Ptr Int -> IO CString
inner = Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> IO (Maybe a) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Ptr Int -> IO CString) -> IO (Maybe a)
forall a. MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)
fromMessageIO Ptr Int -> IO CString
inner

-- | Pass a string to a pure C function.
withCString' :: (CString -> a) -> String -> a
withCString' :: forall a. (CString -> a) -> String -> a
withCString' CString -> a
inner = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> (String -> IO a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> (CString -> IO a) -> IO a)
-> (CString -> IO a) -> String -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> (CString -> IO a) -> IO a
forall a. String -> (CString -> IO a) -> IO a
withCString (a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> (CString -> a) -> CString -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> a
inner)

-- | Return a string from a pure C function
peekCString' :: CString -> String
peekCString' :: CString -> String
peekCString' CString
ptr | CString
ptr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
/= CString
forall a. Ptr a
nullPtr = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
    String
ret <- CString -> IO String
peekCString CString
ptr
    CString -> IO ()
forall a. Ptr a -> IO ()
free CString
ptr
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
ret
  | Bool
otherwise = String
""

-- | Unwrap a foreign pointer to pass to a pure C function.
withForeignPtr' :: (Ptr a -> b) -> ForeignPtr a -> b
withForeignPtr' :: forall a b. (Ptr a -> b) -> ForeignPtr a -> b
withForeignPtr' Ptr a -> b
inner ForeignPtr a
arg = IO b -> b
forall a. IO a -> a
unsafePerformIO (IO b -> b) -> IO b -> b
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
arg ((Ptr a -> IO b) -> IO b) -> (Ptr a -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ b -> IO b
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> IO b) -> (Ptr a -> b) -> Ptr a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr a -> b
inner

-- I don't want to pull in all of inline-c for JUST this util!
-- | Pass a transient pointer to an impure C function,
-- for its value to be returned alongside that functions' return value.
withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b)
withPtr :: forall a b. Storable a => (Ptr a -> IO b) -> IO (a, b)
withPtr Ptr a -> IO b
f = do
  (Ptr a -> IO (a, b)) -> IO (a, b)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO (a, b)) -> IO (a, b))
-> (Ptr a -> IO (a, b)) -> IO (a, b)
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> do
    b
x <- Ptr a -> IO b
f Ptr a
ptr
    a
y <- Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr
    (a, b) -> IO (a, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
y, b
x)