module NanoVG.Internal.FFIHelpers
  (withCString
  ,useAsCStringLen'
  ,useAsPtr
  ,one
  ,null
  ,bitMask
  ) where

import           Control.Monad ((>=>))
import           Data.Bits ((.|.))
import           Data.ByteString hiding (null)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Foreign.C.String (CString)
import           Foreign.C.Types
import           Foreign.Marshal (copyBytes, mallocBytes)
import           Foreign.Ptr
import           Prelude hiding (null)

-- | Marshal a Haskell string into a NUL terminated C string using temporary storage.
withCString :: T.Text -> (CString -> IO b) -> IO b
withCString :: Text -> (CString -> IO b) -> IO b
withCString Text
t = ByteString -> (CString -> IO b) -> IO b
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString (Text -> ByteString
T.encodeUtf8 Text
t)

-- | Wrapper around 'useAsCStringLen' that uses 'CUChar's
useAsCStringLen' :: ByteString -> ((Ptr CUChar,CInt) -> IO a) -> IO a
useAsCStringLen' :: ByteString -> ((Ptr CUChar, CInt) -> IO a) -> IO a
useAsCStringLen' ByteString
bs (Ptr CUChar, CInt) -> IO a
f = ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
useAsCStringLen ByteString
bs ((\(CString
ptr,Int
len) -> (Ptr CUChar, CInt) -> IO (Ptr CUChar, CInt)
forall (m :: * -> *) a. Monad m => a -> m a
return (CString -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr CString
ptr,Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)) (CStringLen -> IO (Ptr CUChar, CInt))
-> ((Ptr CUChar, CInt) -> IO a) -> CStringLen -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Ptr CUChar, CInt) -> IO (Ptr CUChar, CInt)
forall b a. Integral b => (Ptr a, b) -> IO (Ptr a, b)
copyCStringLen ((Ptr CUChar, CInt) -> IO (Ptr CUChar, CInt))
-> ((Ptr CUChar, CInt) -> IO a) -> (Ptr CUChar, CInt) -> IO a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Ptr CUChar, CInt) -> IO a
f)
  where
    -- | Copy memory under given pointer to a new address.
    -- The allocated memory is not garbage-collected and needs to be freed manually later.
    -- In the case of 'createFontMem' and 'createFontMemAtIndex' (the only places using it)
    -- it is freed by NanoVG as a part of 'nvgDeleteGL3'.
    copyCStringLen :: Integral b => (Ptr a, b) -> IO (Ptr a, b)
    copyCStringLen :: (Ptr a, b) -> IO (Ptr a, b)
copyCStringLen (Ptr a
from, b
len) =
      let intLen :: Int
intLen = b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
len
      in do
        Ptr a
to <- Int -> IO (Ptr a)
forall a. Int -> IO (Ptr a)
mallocBytes Int
intLen
        Ptr a -> Ptr a -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr a
to Ptr a
from Int
intLen
        (Ptr a, b) -> IO (Ptr a, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr a
to, b
len)

-- | Wrapper around 'useAsCStringLen'' that discards the length
useAsPtr :: ByteString -> (Ptr CUChar -> IO a) -> IO a
useAsPtr :: ByteString -> (Ptr CUChar -> IO a) -> IO a
useAsPtr ByteString
bs Ptr CUChar -> IO a
f = ByteString -> ((Ptr CUChar, CInt) -> IO a) -> IO a
forall a. ByteString -> ((Ptr CUChar, CInt) -> IO a) -> IO a
useAsCStringLen' ByteString
bs (Ptr CUChar -> IO a
f (Ptr CUChar -> IO a)
-> ((Ptr CUChar, CInt) -> Ptr CUChar) -> (Ptr CUChar, CInt) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ptr CUChar, CInt) -> Ptr CUChar
forall a b. (a, b) -> a
fst)

-- | Marshalling helper for a constant one
one :: Num a => (a -> b) -> b
one :: (a -> b) -> b
one a -> b
f = a -> b
f a
1

-- | Marshalling helper for a constant 'nullPtr'
null :: (Ptr a -> b) -> b
null :: (Ptr a -> b) -> b
null Ptr a -> b
f = Ptr a -> b
f Ptr a
forall a. Ptr a
nullPtr

-- | Combine the values in the set using a bitwise or
bitMask :: Enum a => S.Set a -> CInt
bitMask :: Set a -> CInt
bitMask = (CInt -> CInt -> CInt) -> CInt -> Set CInt -> CInt
forall a b. (a -> b -> b) -> b -> Set a -> b
S.fold CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
(.|.) CInt
0 (Set CInt -> CInt) -> (Set a -> Set CInt) -> Set a -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> CInt) -> Set a -> Set CInt
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> (a -> Int) -> a -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum)