-- | 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 bs = case unpack bs of
    Just (ObjectStr err) |
        Just x <- (readMaybe $ Txt.unpack err :: Maybe FcException) -> throw x
    Just x -> fromObject x
    Nothing -> Nothing

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

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

-- | Decode data via MessagePack returned from a pure C function.
fromMessage :: MessagePack a => (Ptr Int -> CString) -> Maybe a
fromMessage inner = unpackWithErr $ fromStrict $ unsafePerformIO $ do
    unsafePackMallocCStringLen . swap =<< withPtr (throwNull . inner)

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

-- | Decode data via MessagePack returned from an impure C function.
fromMessageIO :: MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)
fromMessageIO inner = do
    (a, b) <- withPtr $ \ptr -> do
        throwNull =<< inner ptr
    bs <- unsafePackMallocCStringLen (b, a)
    return $ unpackWithErr $ fromStrict 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 inner = fromJust <$> fromMessageIO inner

-- | Pass a string to a pure C function.
withCString' :: (CString -> a) -> String -> a
withCString' inner = unsafePerformIO . flip withCString (return . inner)

-- | Return a string from a pure C function
peekCString' :: CString -> String
peekCString' ptr | ptr /= nullPtr = unsafePerformIO $ do
    ret <- peekCString ptr
    free ptr
    return ret
  | otherwise = ""

-- | Unwrap a foreign pointer to pass to a pure C function.
withForeignPtr' :: (Ptr a -> b) -> ForeignPtr a -> b
withForeignPtr' inner arg = unsafePerformIO $ withForeignPtr arg $ return . 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 f = do
  alloca $ \ptr -> do
    x <- f ptr
    y <- peek ptr
    return (y, x)