{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE BangPatterns #-}
module GHC.Foreign (
peekCString,
peekCStringLen,
newCString,
newCStringLen,
withCString,
withCStringLen,
withCStringsLen,
charIsRepresentable,
) where
import Foreign.Marshal.Array
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import Data.Word
import Data.Tuple (fst)
import GHC.Show ( show )
import Foreign.Marshal.Alloc
import Foreign.ForeignPtr
import GHC.Debug
import GHC.List
import GHC.Num
import GHC.Base
import GHC.IO
import GHC.IO.Exception
import GHC.IO.Buffer
import GHC.IO.Encoding.Types
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP :: Bool
c_DEBUG_DUMP = Bool
False
putDebugMsg :: String -> IO ()
putDebugMsg :: String -> IO ()
putDebugMsg | Bool
c_DEBUG_DUMP = String -> IO ()
debugLn
| Bool
otherwise = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
type CString = Ptr CChar
type CStringLen = (Ptr CChar, Int)
peekCString :: TextEncoding -> CString -> IO String
peekCString :: TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cp = do
Int
sz <- forall a. (Storable a, Eq a) => a -> Ptr a -> IO Int
lengthArray0 CChar
nUL CString
cp
TextEncoding -> CStringLen -> IO String
peekEncodedCString TextEncoding
enc (CString
cp, Int
sz forall a. Num a => a -> a -> a
* Int
cCharSize)
peekCStringLen :: TextEncoding -> CStringLen -> IO String
peekCStringLen :: TextEncoding -> CStringLen -> IO String
peekCStringLen = TextEncoding -> CStringLen -> IO String
peekEncodedCString
newCString :: TextEncoding -> String -> IO CString
newCString :: TextEncoding -> String -> IO CString
newCString TextEncoding
enc = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString TextEncoding
enc Bool
True
newCStringLen :: TextEncoding -> String -> IO CStringLen
newCStringLen :: TextEncoding -> String -> IO CStringLen
newCStringLen TextEncoding
enc = TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString TextEncoding
enc Bool
False
withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a
withCString :: forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
s CString -> IO a
act = forall a.
TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString TextEncoding
enc Bool
True String
s forall a b. (a -> b) -> a -> b
$ \(CString
cp, Int
_sz) -> CString -> IO a
act CString
cp
withCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
withCStringLen :: forall a. TextEncoding -> String -> (CStringLen -> IO a) -> IO a
withCStringLen TextEncoding
enc = forall a.
TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString TextEncoding
enc Bool
False
withCStringsLen :: TextEncoding
-> [String]
-> (Int -> Ptr CString -> IO a)
-> IO a
withCStringsLen :: forall a.
TextEncoding -> [String] -> (Int -> Ptr CString -> IO a) -> IO a
withCStringsLen TextEncoding
enc [String]
strs Int -> Ptr CString -> IO a
f = [CString] -> [String] -> IO a
go [] [String]
strs
where
go :: [CString] -> [String] -> IO a
go [CString]
cs (String
s:[String]
ss) = forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc String
s forall a b. (a -> b) -> a -> b
$ \CString
c -> [CString] -> [String] -> IO a
go (CString
cforall a. a -> [a] -> [a]
:[CString]
cs) [String]
ss
go [CString]
cs [] = forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen (forall a. [a] -> [a]
reverse [CString]
cs) Int -> Ptr CString -> IO a
f
charIsRepresentable :: TextEncoding -> Char -> IO Bool
charIsRepresentable :: TextEncoding -> Char -> IO Bool
charIsRepresentable !TextEncoding
enc Char
c =
forall a. TextEncoding -> String -> (CString -> IO a) -> IO a
withCString TextEncoding
enc [Char
c]
(\CString
cstr -> do String
str <- TextEncoding -> CString -> IO String
peekCString TextEncoding
enc CString
cstr
case String
str of
[Char
ch] | Char
ch forall a. Eq a => a -> a -> Bool
== Char
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
nUL :: CChar
nUL :: CChar
nUL = CChar
0
cCharSize :: Int
cCharSize :: Int
cCharSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: CChar)
{-# INLINE peekEncodedCString #-}
peekEncodedCString :: TextEncoding
-> CStringLen
-> IO String
peekEncodedCString :: TextEncoding -> CStringLen -> IO String
peekEncodedCString (TextEncoding { mkTextDecoder :: ()
mkTextDecoder = IO (TextDecoder dstate)
mk_decoder }) (CString
p, Int
sz_bytes)
= forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextDecoder dstate)
mk_decoder forall from to state. BufferCodec from to state -> IO ()
close forall a b. (a -> b) -> a -> b
$ \TextDecoder dstate
decoder -> do
let chunk_size :: Int
chunk_size = Int
sz_bytes forall a. Ord a => a -> a -> a
`max` Int
1
Buffer Word8
from0 <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RawBuffer Word8
fp -> forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz_bytes (forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Word8
fp Int
sz_bytes BufferState
ReadBuffer)) forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ (forall a b. Ptr a -> Ptr b
castPtr CString
p)
CharBuffer
to <- Int -> BufferState -> IO CharBuffer
newCharBuffer Int
chunk_size BufferState
WriteBuffer
let go :: t -> Buffer Word8 -> IO String
go !t
iteration Buffer Word8
from = do
(CodingProgress
why, Buffer Word8
from', CharBuffer
to') <- forall from to state.
BufferCodec from to state -> CodeBuffer from to
encode TextDecoder dstate
decoder Buffer Word8
from CharBuffer
to
if forall e. Buffer e -> Bool
isEmptyBuffer Buffer Word8
from'
then
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer CharBuffer
to' forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (forall e. Buffer e -> Int
bufferElems CharBuffer
to')
else do
String -> IO ()
putDebugMsg (String
"peekEncodedCString: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
iteration forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CodingProgress
why)
(Buffer Word8
from'', CharBuffer
to'') <- case CodingProgress
why of CodingProgress
InvalidSequence -> forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextDecoder dstate
decoder Buffer Word8
from' CharBuffer
to'
CodingProgress
InputUnderflow -> forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextDecoder dstate
decoder Buffer Word8
from' CharBuffer
to'
CodingProgress
OutputUnderflow -> forall (m :: * -> *) a. Monad m => a -> m a
return (Buffer Word8
from', CharBuffer
to')
String -> IO ()
putDebugMsg (String
"peekEncodedCString: from " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer Buffer Word8
from forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer Buffer Word8
from' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer Buffer Word8
from'')
String -> IO ()
putDebugMsg (String
"peekEncodedCString: to " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer CharBuffer
to forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer CharBuffer
to' forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer CharBuffer
to'')
String
to_chars <- forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer CharBuffer
to'' forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (forall e. Buffer e -> Int
bufferElems CharBuffer
to'')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String
to_charsforall a. [a] -> [a] -> [a]
++) forall a b. (a -> b) -> a -> b
$ t -> Buffer Word8 -> IO String
go (t
iteration forall a. Num a => a -> a -> a
+ t
1) Buffer Word8
from''
forall {t}. (Show t, Num t) => t -> Buffer Word8 -> IO String
go (Int
0 :: Int) Buffer Word8
from0
{-# INLINE withEncodedCString #-}
withEncodedCString :: TextEncoding
-> Bool
-> String
-> (CStringLen -> IO a)
-> IO a
withEncodedCString :: forall a.
TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO a
withEncodedCString (TextEncoding { mkTextEncoder :: ()
mkTextEncoder = IO (TextEncoder estate)
mk_encoder }) Bool
null_terminate String
s CStringLen -> IO a
act
= forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextEncoder estate)
mk_encoder forall from to state. BufferCodec from to state -> IO ()
close forall a b. (a -> b) -> a -> b
$ \TextEncoder estate
encoder -> forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen String
s forall a b. (a -> b) -> a -> b
$ \Int
sz Ptr Char
p -> do
CharBuffer
from <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RawBuffer Char
fp -> forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz (forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Char
fp Int
sz BufferState
ReadBuffer)) forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Char
p
let go :: t -> Int -> IO a
go !t
iteration Int
to_sz_bytes = do
String -> IO ()
putDebugMsg (String
"withEncodedCString: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
iteration)
forall a b. Int -> (Ptr a -> IO b) -> IO b
allocaBytes Int
to_sz_bytes forall a b. (a -> b) -> a -> b
$ \Ptr Word8
to_p -> do
Maybe (Buffer Word8)
mb_res <- forall dstate.
TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> IO (Maybe (Buffer Word8))
tryFillBuffer TextEncoder estate
encoder Bool
null_terminate CharBuffer
from Ptr Word8
to_p Int
to_sz_bytes
case Maybe (Buffer Word8)
mb_res of
Maybe (Buffer Word8)
Nothing -> t -> Int -> IO a
go (t
iteration forall a. Num a => a -> a -> a
+ t
1) (Int
to_sz_bytes forall a. Num a => a -> a -> a
* Int
2)
Just Buffer Word8
to_buf -> forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
withCStringBuffer Buffer Word8
to_buf Bool
null_terminate CStringLen -> IO a
act
forall {t}. (Show t, Num t) => t -> Int -> IO a
go (Int
0 :: Int) (Int
cCharSize forall a. Num a => a -> a -> a
* (Int
sz forall a. Num a => a -> a -> a
+ Int
1))
withCStringBuffer :: Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
withCStringBuffer :: forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
withCStringBuffer Buffer Word8
to_buf Bool
null_terminate CStringLen -> IO r
act = do
let bytes :: Int
bytes = forall e. Buffer e -> Int
bufferElems Buffer Word8
to_buf
forall e a. Buffer e -> (Ptr e -> IO a) -> IO a
withBuffer Buffer Word8
to_buf forall a b. (a -> b) -> a -> b
$ \Ptr Word8
to_ptr -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
null_terminate forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
to_ptr (forall e. Buffer e -> Int
bufR Buffer Word8
to_buf) Word8
0
CStringLen -> IO r
act (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
to_ptr, Int
bytes)
{-# INLINE newEncodedCString #-}
newEncodedCString :: TextEncoding
-> Bool
-> String
-> IO CStringLen
newEncodedCString :: TextEncoding -> Bool -> String -> IO CStringLen
newEncodedCString (TextEncoding { mkTextEncoder :: ()
mkTextEncoder = IO (TextEncoder estate)
mk_encoder }) Bool
null_terminate String
s
= forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (TextEncoder estate)
mk_encoder forall from to state. BufferCodec from to state -> IO ()
close forall a b. (a -> b) -> a -> b
$ \TextEncoder estate
encoder -> forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b
withArrayLen String
s forall a b. (a -> b) -> a -> b
$ \Int
sz Ptr Char
p -> do
CharBuffer
from <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\RawBuffer Char
fp -> forall e. Int -> Buffer e -> Buffer e
bufferAdd Int
sz (forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Char
fp Int
sz BufferState
ReadBuffer)) forall a b. (a -> b) -> a -> b
$ forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Char
p
let go :: t -> Ptr Word8 -> Int -> IO CStringLen
go !t
iteration Ptr Word8
to_p Int
to_sz_bytes = do
String -> IO ()
putDebugMsg (String
"newEncodedCString: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
iteration)
Maybe (Buffer Word8)
mb_res <- forall dstate.
TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> IO (Maybe (Buffer Word8))
tryFillBuffer TextEncoder estate
encoder Bool
null_terminate CharBuffer
from Ptr Word8
to_p Int
to_sz_bytes
case Maybe (Buffer Word8)
mb_res of
Maybe (Buffer Word8)
Nothing -> do
let to_sz_bytes' :: Int
to_sz_bytes' = Int
to_sz_bytes forall a. Num a => a -> a -> a
* Int
2
Ptr Word8
to_p' <- forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
to_p Int
to_sz_bytes'
t -> Ptr Word8 -> Int -> IO CStringLen
go (t
iteration forall a. Num a => a -> a -> a
+ t
1) Ptr Word8
to_p' Int
to_sz_bytes'
Just Buffer Word8
to_buf -> forall r. Buffer Word8 -> Bool -> (CStringLen -> IO r) -> IO r
withCStringBuffer Buffer Word8
to_buf Bool
null_terminate forall (m :: * -> *) a. Monad m => a -> m a
return
let to_sz_bytes :: Int
to_sz_bytes = Int
cCharSize forall a. Num a => a -> a -> a
* (Int
sz forall a. Num a => a -> a -> a
+ Int
1)
Ptr Word8
to_p <- forall a. Int -> IO (Ptr a)
mallocBytes Int
to_sz_bytes
forall {t}.
(Show t, Num t) =>
t -> Ptr Word8 -> Int -> IO CStringLen
go (Int
0 :: Int) Ptr Word8
to_p Int
to_sz_bytes
tryFillBuffer :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
-> IO (Maybe (Buffer Word8))
tryFillBuffer :: forall dstate.
TextEncoder dstate
-> Bool
-> CharBuffer
-> Ptr Word8
-> Int
-> IO (Maybe (Buffer Word8))
tryFillBuffer TextEncoder dstate
encoder Bool
null_terminate CharBuffer
from0 Ptr Word8
to_p Int
to_sz_bytes = do
RawBuffer Word8
to_fp <- forall a. Ptr a -> IO (ForeignPtr a)
newForeignPtr_ Ptr Word8
to_p
forall {t}.
(Show t, Num t) =>
t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
go (Int
0 :: Int) (CharBuffer
from0, forall e. RawBuffer e -> Int -> BufferState -> Buffer e
emptyBuffer RawBuffer Word8
to_fp Int
to_sz_bytes BufferState
WriteBuffer)
where
go :: t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
go !t
iteration (CharBuffer
from, Buffer Word8
to) = do
(CodingProgress
why, CharBuffer
from', Buffer Word8
to') <- forall from to state.
BufferCodec from to state -> CodeBuffer from to
encode TextEncoder dstate
encoder CharBuffer
from Buffer Word8
to
String -> IO ()
putDebugMsg (String
"tryFillBufferAndCall: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show t
iteration forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CodingProgress
why forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer CharBuffer
from forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Buffer a -> String
summaryBuffer CharBuffer
from')
if forall e. Buffer e -> Bool
isEmptyBuffer CharBuffer
from'
then if Bool
null_terminate Bool -> Bool -> Bool
&& forall e. Buffer e -> Int
bufferAvailable Buffer Word8
to' forall a. Eq a => a -> a -> Bool
== Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Buffer Word8
to')
else case CodingProgress
why of
CodingProgress
InputUnderflow -> forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextEncoder dstate
encoder CharBuffer
from' Buffer Word8
to' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
go (t
iteration forall a. Num a => a -> a -> a
+ t
1)
CodingProgress
InvalidSequence -> forall from to state.
BufferCodec from to state
-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)
recover TextEncoder dstate
encoder CharBuffer
from' Buffer Word8
to' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> (CharBuffer, Buffer Word8) -> IO (Maybe (Buffer Word8))
go (t
iteration forall a. Num a => a -> a -> a
+ t
1)
CodingProgress
OutputUnderflow -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing