-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{- | Utilities for C wrappers.

    - Functions to convert between haskell and c types.

    - Generic UI debugging functions.
-}
module Util.FFI where
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as Unsafe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Encoding
import qualified Data.Text.Encoding.Error as Encoding.Error
import qualified Data.Word as Word

import qualified Foreign
import qualified ForeignC

import qualified Util.Num as Num

import           Foreign.C
import           Global


-- * convert

c_int :: Int -> CInt
c_int :: Int -> CInt
c_int = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -- c ints should be at least as big as hs ones

c_nat :: Int -> CInt
c_nat :: Int -> CInt
c_nat = Int -> CInt
c_int -- I don't check for > 0 yet, I should catch the c++ exception

c_uchar :: Integral a => a -> CUChar
c_uchar :: forall a. Integral a => a -> CUChar
c_uchar = a -> CUChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> CUChar) -> (a -> a) -> a -> CUChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> a -> a
forall a. Ord a => a -> a -> a -> a
Num.clamp a
0 a
255

c_char :: Char -> CChar
c_char :: Char -> CChar
c_char = Int -> CChar
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CChar) -> (Char -> Int) -> Char -> CChar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int -> Int
forall a. Ord a => a -> a -> a -> a
Num.clamp Int
0 Int
127 (Int -> Int) -> (Char -> Int) -> Char -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum

-- | This corresponds to utf8::rune.
c_rune :: Char -> Word.Word32
c_rune :: Char -> Word32
c_rune = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum

c_double :: Double -> CDouble
c_double :: Double -> CDouble
c_double = Double -> CDouble
CDouble

c_float :: Float -> CFloat
c_float :: Float -> CFloat
c_float = Float -> CFloat
CFloat

hs_double :: CDouble -> Double
hs_double :: CDouble -> Double
hs_double (CDouble Double
d) = Double
d

-- | bool is C++, not C, so I represent bools as chars.
c_bool :: Bool -> CChar
c_bool :: Bool -> CChar
c_bool Bool
True = CChar
1
c_bool Bool
False = CChar
0

-- | Copy the bytestring to a null-terminated cstring, in malloc'd space.
-- ByteString only has an alloca version of this.
bytesToCString0 :: ByteString.ByteString -> IO CString
bytesToCString0 :: ByteString -> IO CString
bytesToCString0 ByteString
bs = ByteString -> (CStringLen -> IO CString) -> IO CString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
Unsafe.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO CString) -> IO CString)
-> (CStringLen -> IO CString) -> IO CString
forall a b. (a -> b) -> a -> b
$ \(CString
str, Int
len) -> do
    CString
new <- Int -> IO CString
forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    CString -> CString -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes CString
new CString
str Int
len
    Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
Foreign.poke (CString
new CString -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`Foreign.plusPtr` Int
len) (Word8
0 :: Word.Word8)
    CString -> IO CString
forall (m :: * -> *) a. Monad m => a -> m a
return CString
new

-- | Allocate a new UTF8-encoded null-terminated CString.
--
-- This copies the string twice, but I think I'd need a encodeUtf8 that can
-- write directly to a pointer to solve that.
newCString0 :: Text -> IO CString
newCString0 :: Text -> IO CString
newCString0 = ByteString -> IO CString
bytesToCString0 (ByteString -> IO CString)
-> (Text -> ByteString) -> Text -> IO CString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

-- | Like 'newCString0', but optimize "" to nullptr.  The C++ side has to
-- be prepared for this.
newCStringNull0 :: Text -> IO CString
newCStringNull0 :: Text -> IO CString
newCStringNull0 Text
t
    | Text -> Bool
Text.null Text
t = CString -> IO CString
forall (m :: * -> *) a. Monad m => a -> m a
return CString
forall a. Ptr a
Foreign.nullPtr
    | Bool
otherwise = Text -> IO CString
newCString0 Text
t

peekCString :: CString -> IO Text
peekCString :: CString -> IO Text
peekCString CString
cstr
    | CString
cstr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
Foreign.nullPtr = Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
Text.empty
    | Bool
otherwise = (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (IO ByteString -> IO Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> a -> b
$ CString -> IO ByteString
ByteString.packCString CString
cstr

withText :: Text -> (CString -> IO a) -> IO a
withText :: forall a. Text -> (CString -> IO a) -> IO a
withText = ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString (ByteString -> (CString -> IO a) -> IO a)
-> (Text -> ByteString) -> Text -> (CString -> IO a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Encoding.encodeUtf8

decodeUtf8 :: ByteString.ByteString -> Text
decodeUtf8 :: ByteString -> Text
decodeUtf8 = OnDecodeError -> ByteString -> Text
Encoding.decodeUtf8With OnDecodeError
Encoding.Error.lenientDecode

-- * ForeignPtr

withForeignPtrs :: [Foreign.ForeignPtr a] -> ([Foreign.Ptr a] -> IO b) -> IO b
withForeignPtrs :: forall a b. [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withForeignPtrs [ForeignPtr a]
fps = [Ptr a] -> [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
forall {a} {b}.
[Ptr a] -> [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withfp [] [ForeignPtr a]
fps
    where
    withfp :: [Ptr a] -> [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withfp [Ptr a]
ps [] [Ptr a] -> IO b
action = [Ptr a] -> IO b
action ([Ptr a] -> [Ptr a]
forall a. [a] -> [a]
reverse [Ptr a]
ps)
    withfp [Ptr a]
ps (ForeignPtr a
fp:[ForeignPtr a]
rest) [Ptr a] -> IO b
action =
        ForeignPtr a -> (Ptr a -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
Foreign.withForeignPtr ForeignPtr a
fp (\Ptr a
p -> [Ptr a] -> [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withfp (Ptr a
pPtr a -> [Ptr a] -> [Ptr a]
forall a. a -> [a] -> [a]
:[Ptr a]
ps) [ForeignPtr a]
rest [Ptr a] -> IO b
action)

-- * FunPtr

-- | Forgetting to call freeHaskellFunPtr is an easy way to leak memory.
-- So all FunPtrs should be created with this function, and always bee freed
-- with 'freeFunPtr'.  That way I can log creates and frees to ensure they
-- are balanced.  Use @tools/track_funptr.py@ to automate that.
makeFunPtr :: String -> IO (Foreign.FunPtr a) -> IO (Foreign.FunPtr a)
makeFunPtr :: forall a. String -> IO (FunPtr a) -> IO (FunPtr a)
makeFunPtr String
_name IO (FunPtr a)
make = do
    FunPtr a
fptr <- IO (FunPtr a)
make
    -- putStrLn $ "+ " ++ show fptr ++ " " ++ _name
    FunPtr a -> IO (FunPtr a)
forall (m :: * -> *) a. Monad m => a -> m a
return FunPtr a
fptr

freeFunPtr :: Foreign.FunPtr a -> IO ()
freeFunPtr :: forall a. FunPtr a -> IO ()
freeFunPtr FunPtr a
fptr = do
    -- putStrLn $ "- " ++ show fptr
    FunPtr a -> IO ()
forall a. FunPtr a -> IO ()
Foreign.freeHaskellFunPtr FunPtr a
fptr

-- | This should be in c-storable, but updating via hackage is such a pain I'll
-- inline it for now.
new :: ForeignC.CStorable a => a -> IO (Foreign.Ptr a)
new :: forall a. CStorable a => a -> IO (Ptr a)
new a
val  = do
    Ptr a
ptr <- IO (Ptr a)
forall a. CStorable a => IO (Ptr a)
ForeignC.malloc
    Ptr a -> a -> IO ()
forall a. CStorable a => Ptr a -> a -> IO ()
ForeignC.poke Ptr a
ptr a
val
    Ptr a -> IO (Ptr a)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr