-- 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 = 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => a -> a -> a -> a
Num.clamp a
0 a
255

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

-- | This corresponds to utf8::rune.
c_rune :: Char -> Word.Word32
c_rune :: Char -> Word32
c_rune = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a. ByteString -> (CStringLen -> IO a) -> IO a
Unsafe.unsafeUseAsCStringLen ByteString
bs forall a b. (a -> b) -> a -> b
$ \(CString
str, Int
len) -> do
    CString
new <- forall a. Int -> IO (Ptr a)
Foreign.mallocBytes (Int
lenforall a. Num a => a -> a -> a
+Int
1)
    forall a. Ptr a -> Ptr a -> Int -> IO ()
Foreign.copyBytes CString
new CString
str Int
len
    forall a. Storable a => Ptr a -> a -> IO ()
Foreign.poke (CString
new forall a b. Ptr a -> Int -> Ptr b
`Foreign.plusPtr` Int
len) (Word8
0 :: Word.Word8)
    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 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 = forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
Foreign.nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return Text
Text.empty
    | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 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 = forall a. ByteString -> (CString -> IO a) -> IO a
ByteString.useAsCString 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 = 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 (forall a. [a] -> [a]
reverse [Ptr a]
ps)
    withfp [Ptr a]
ps (ForeignPtr a
fp:[ForeignPtr a]
rest) [Ptr a] -> IO b
action =
        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
pforall 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
    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
    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 <- forall a. CStorable a => IO (Ptr a)
ForeignC.malloc
    forall a. CStorable a => Ptr a -> a -> IO ()
ForeignC.poke Ptr a
ptr a
val
    forall (m :: * -> *) a. Monad m => a -> m a
return Ptr a
ptr