{-# LANGUAGE BlockArguments, TupleSections #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

module Data.Text.Tools (pokeText, cstringToText) where

import Foreign.Ptr
import Foreign.Marshal.Utils
import Foreign.Storable
import Foreign.C.Types
import Foreign.C.String

import qualified Data.Text as Txt
import qualified Data.Text.Foreign as Txt

pokeText :: Int -> CString -> Txt.Text -> IO ()
pokeText :: Int -> CString -> Text -> IO ()
pokeText Int
mx CString
dst Text
t = Text -> (CStringLen -> IO ()) -> IO ()
forall a. Text -> (CStringLen -> IO a) -> IO a
Txt.withCStringLen Text
t \(CString
src, Int
ln) -> do
	let	ln' :: Int
ln' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
ln (Int
mx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
	CString -> CString -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes CString
dst CString
src Int
ln'
	CString -> CChar -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (CString
dst CString -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ln' :: Ptr CChar) CChar
0

cstringToText :: CString -> IO Txt.Text
cstringToText :: CString -> IO Text
cstringToText CString
cs = CStringLen -> IO Text
Txt.peekCStringLen (CStringLen -> IO Text) -> IO CStringLen -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO CStringLen
cstringToCStringLen CString
cs

cstringToCStringLen :: CString -> IO CStringLen
cstringToCStringLen :: CString -> IO CStringLen
cstringToCStringLen CString
cs = (CString
cs ,) (Int -> CStringLen) -> IO Int -> IO CStringLen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO Int
cstringLength CString
cs

cstringLength :: CString -> IO Int
cstringLength :: CString -> IO Int
cstringLength CString
pc = do
	c <- CString -> IO CChar
forall a. Storable a => Ptr a -> IO a
peek CString
pc
	case c of
		CChar
0 -> Int -> IO Int
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
0
		CChar
_ -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int -> Int) -> IO Int -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO Int
cstringLength (CString
pc CString -> Int -> CString
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)