Movatterモバイル変換

{-# LANGUAGE Trustworthy #-}{-# LANGUAGE NoImplicitPrelude #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE BangPatterns #-}------------------------------------------------------------------------------- |-- Module      :  GHC.Foreign-- Copyright   :  (c) The University of Glasgow, 2008-2011-- License     :  see libraries/base/LICENSE---- Maintainer  :  libraries@haskell.org-- Stability   :  internal-- Portability :  non-portable---- Foreign marshalling support for CStrings with configurable encodings-------------------------------------------------------------------------------moduleGHC.Foreign(-- * C strings with a configurable encoding-- conversion of C strings into Haskell strings--peekCString,peekCStringLen,-- conversion of Haskell strings into C strings--newCString,newCStringLen,-- conversion of Haskell strings into C strings using temporary storage--withCString,withCStringLen,withCStringsLen,charIsRepresentable,)whereimportForeign.Marshal.ArrayimportForeign.C.TypesimportForeign.PtrimportForeign.StorableimportData.Word-- Imports for the locale-encoding version of marshallersimportData.Tuple(fst)importGHC.Show(show)importForeign.Marshal.AllocimportForeign.ForeignPtrimportGHC.DebugimportGHC.ListimportGHC.NumimportGHC.BaseimportGHC.IOimportGHC.IO.ExceptionimportGHC.IO.BufferimportGHC.IO.Encoding.Typesc_DEBUG_DUMP::Boolc_DEBUG_DUMP :: Boolc_DEBUG_DUMP=BoolFalseputDebugMsg::String->IO()putDebugMsg :: String -> IO ()putDebugMsg|Boolc_DEBUG_DUMP=String -> IO ()debugLn|Boolotherwise=IO () -> String -> IO ()forall a b. a -> b -> aconst(() -> IO ()forall (m :: * -> *) a. Monad m => a -> m areturn())-- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:typeCString=PtrCChartypeCStringLen=(PtrCChar,Int)-- exported functions-- -------------------- | Marshal a NUL terminated C string into a Haskell string.--peekCString::TextEncoding->CString->IOStringpeekCString :: TextEncoding -> CString -> IO StringpeekCStringTextEncodingencCStringcp=doIntsz<-CChar -> CString -> IO Intforall a. (Storable a, Eq a) => a -> Ptr a -> IO IntlengthArray0CCharnULCStringcpTextEncoding -> CStringLen -> IO StringpeekEncodedCStringTextEncodingenc(CStringcp,IntszInt -> Int -> Intforall a. Num a => a -> a -> a*IntcCharSize)-- | Marshal a C string with explicit length into a Haskell string.--peekCStringLen::TextEncoding->CStringLen->IOStringpeekCStringLen :: TextEncoding -> CStringLen -> IO StringpeekCStringLen=TextEncoding -> CStringLen -> IO StringpeekEncodedCString-- | Marshal a Haskell string into a NUL terminated C string.---- * the Haskell string may /not/ contain any NUL characters---- * new storage is allocated for the C string and must be--   explicitly freed using 'Foreign.Marshal.Alloc.free' or--   'Foreign.Marshal.Alloc.finalizerFree'.--newCString::TextEncoding->String->IOCStringnewCString :: TextEncoding -> String -> IO CStringnewCStringTextEncodingenc=(CStringLen -> CString) -> IO CStringLen -> IO CStringforall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m rliftMCStringLen -> CStringforall a b. (a, b) -> afst(IO CStringLen -> IO CString)-> (String -> IO CStringLen) -> String -> IO CStringforall b c a. (b -> c) -> (a -> b) -> a -> c.TextEncoding -> Bool -> String -> IO CStringLennewEncodedCStringTextEncodingencBoolTrue-- | Marshal a Haskell string into a C string (ie, character array) with-- explicit length information.---- * new storage is allocated for the C string and must be--   explicitly freed using 'Foreign.Marshal.Alloc.free' or--   'Foreign.Marshal.Alloc.finalizerFree'.--newCStringLen::TextEncoding->String->IOCStringLennewCStringLen :: TextEncoding -> String -> IO CStringLennewCStringLenTextEncodingenc=TextEncoding -> Bool -> String -> IO CStringLennewEncodedCStringTextEncodingencBoolFalse-- | Marshal a Haskell string into a NUL terminated C string using temporary-- storage.---- * the Haskell string may /not/ contain any NUL characters---- * the memory is freed when the subcomputation terminates (either--   normally or via an exception), so the pointer to the temporary--   storage must /not/ be used after this.--withCString::TextEncoding->String->(CString->IOa)->IOawithCString :: TextEncoding -> String -> (CString -> IO a) -> IO awithCStringTextEncodingencStringsCString -> IO aact=TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO aforall a.TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO awithEncodedCStringTextEncodingencBoolTrueStrings((CStringLen -> IO a) -> IO a) -> (CStringLen -> IO a) -> IO aforall a b. (a -> b) -> a -> b$\(CStringcp,Int_sz)->CString -> IO aactCStringcp-- | Marshal a Haskell string into a C string (ie, character array)-- in temporary storage, with explicit length information.---- * the memory is freed when the subcomputation terminates (either--   normally or via an exception), so the pointer to the temporary--   storage must /not/ be used after this.--withCStringLen::TextEncoding->String->(CStringLen->IOa)->IOawithCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO awithCStringLenTextEncodingenc=TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO aforall a.TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO awithEncodedCStringTextEncodingencBoolFalse-- | Marshal a list of Haskell strings into an array of NUL terminated C strings-- using temporary storage.---- * the Haskell strings may /not/ contain any NUL characters---- * the memory is freed when the subcomputation terminates (either--   normally or via an exception), so the pointer to the temporary--   storage must /not/ be used after this.--withCStringsLen::TextEncoding->[String]->(Int->PtrCString->IOa)->IOawithCStringsLen :: TextEncoding -> [String] -> (Int -> Ptr CString -> IO a) -> IO awithCStringsLenTextEncodingenc[String]strsInt -> Ptr CString -> IO af=[CString] -> [String] -> IO ago[][String]strswherego :: [CString] -> [String] -> IO ago[CString]cs(Strings:[String]ss)=TextEncoding -> String -> (CString -> IO a) -> IO aforall a. TextEncoding -> String -> (CString -> IO a) -> IO awithCStringTextEncodingencStrings((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO aforall a b. (a -> b) -> a -> b$\CStringc->[CString] -> [String] -> IO ago(CStringcCString -> [CString] -> [CString]forall a. a -> [a] -> [a]:[CString]cs)[String]ssgo[CString]cs[]=[CString] -> (Int -> Ptr CString -> IO a) -> IO aforall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO bwithArrayLen([CString] -> [CString]forall a. [a] -> [a]reverse[CString]cs)Int -> Ptr CString -> IO af-- | Determines whether a character can be accurately encoded in a-- 'Foreign.C.String.CString'.---- Pretty much anyone who uses this function is in a state of sin because-- whether or not a character is encodable will, in general, depend on the-- context in which it occurs.charIsRepresentable::TextEncoding->Char->IOBool-- We force enc explicitly because `catch` is lazy in its-- first argument. We would probably like to force c as well,-- but unfortunately worker/wrapper produces very bad code for-- that.---- TODO If this function is performance-critical, it would probably-- pay to use a single-character specialization of withCString. That-- would allow worker/wrapper to actually eliminate Char boxes, and-- would also get rid of the completely unnecessary cons allocation.charIsRepresentable :: TextEncoding -> Char -> IO BoolcharIsRepresentable!TextEncodingencCharc=TextEncoding -> String -> (CString -> IO Bool) -> IO Boolforall a. TextEncoding -> String -> (CString -> IO a) -> IO awithCStringTextEncodingenc[Charc](\CStringcstr->doStringstr<-TextEncoding -> CString -> IO StringpeekCStringTextEncodingencCStringcstrcaseStringstrof[Charch]|CharchChar -> Char -> Boolforall a. Eq a => a -> a -> Bool==Charc->Bool -> IO Boolforall (f :: * -> *) a. Applicative f => a -> f apureBoolTrueString_->Bool -> IO Boolforall (f :: * -> *) a. Applicative f => a -> f apureBoolFalse)IO Bool -> (IOException -> IO Bool) -> IO Boolforall e a. Exception e => IO a -> (e -> IO a) -> IO a`catch`\(IOException_::IOException)->Bool -> IO Boolforall (f :: * -> *) a. Applicative f => a -> f apureBoolFalse-- auxiliary definitions-- ------------------------ C's end of string characternUL::CCharnUL :: CCharnUL=CChar0-- Size of a CChar in bytescCharSize::IntcCharSize :: IntcCharSize=CChar -> Intforall a. Storable a => a -> IntsizeOf(CCharforall a. HasCallStack => aundefined::CChar){-# INLINEpeekEncodedCString#-}peekEncodedCString::TextEncoding-- ^ Encoding of CString->CStringLen->IOString-- ^ String in Haskell termspeekEncodedCString :: TextEncoding -> CStringLen -> IO StringpeekEncodedCString(TextEncoding{mkTextDecoder :: ()mkTextDecoder=IO (TextDecoder dstate)mk_decoder})(CStringp,Intsz_bytes)=IO (TextDecoder dstate)-> (TextDecoder dstate -> IO ())-> (TextDecoder dstate -> IO String)-> IO Stringforall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO cbracketIO (TextDecoder dstate)mk_decoderTextDecoder dstate -> IO ()forall from to state. BufferCodec from to state -> IO ()close((TextDecoder dstate -> IO String) -> IO String)-> (TextDecoder dstate -> IO String) -> IO Stringforall a b. (a -> b) -> a -> b$\TextDecoder dstatedecoder->doletchunk_size :: Intchunk_size=Intsz_bytesInt -> Int -> Intforall a. Ord a => a -> a -> a`max`Int1-- Decode buffer chunk size in characters: one iteration only for ASCIIBuffer Word8from0<-(RawBuffer Word8 -> Buffer Word8)-> IO (RawBuffer Word8) -> IO (Buffer Word8)forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f bfmap(\RawBuffer Word8fp->Int -> Buffer Word8 -> Buffer Word8forall e. Int -> Buffer e -> Buffer ebufferAddIntsz_bytes(RawBuffer Word8 -> Int -> BufferState -> Buffer Word8forall e. RawBuffer e -> Int -> BufferState -> Buffer eemptyBufferRawBuffer Word8fpIntsz_bytesBufferStateReadBuffer))(IO (RawBuffer Word8) -> IO (Buffer Word8))-> IO (RawBuffer Word8) -> IO (Buffer Word8)forall a b. (a -> b) -> a -> b$Ptr Word8 -> IO (RawBuffer Word8)forall a. Ptr a -> IO (ForeignPtr a)newForeignPtr_(CString -> Ptr Word8forall a b. Ptr a -> Ptr bcastPtrCStringp)CharBufferto<-Int -> BufferState -> IO CharBuffernewCharBufferIntchunk_sizeBufferStateWriteBufferletgo :: t -> Buffer Word8 -> IO Stringgo!titerationBuffer Word8from=do(CodingProgresswhy,Buffer Word8from',CharBufferto')<-TextDecoder dstate -> CodeBuffer Word8 Charforall from to state.BufferCodec from to state -> CodeBuffer from toencodeTextDecoder dstatedecoderBuffer Word8fromCharBuffertoifBuffer Word8 -> Boolforall e. Buffer e -> BoolisEmptyBufferBuffer Word8from'then-- No input remaining: @why@ will be InputUnderflow, but we don't careCharBuffer -> (Ptr Char -> IO String) -> IO Stringforall e a. Buffer e -> (Ptr e -> IO a) -> IO awithBufferCharBufferto'((Ptr Char -> IO String) -> IO String)-> (Ptr Char -> IO String) -> IO Stringforall a b. (a -> b) -> a -> b$Int -> Ptr Char -> IO Stringforall a. Storable a => Int -> Ptr a -> IO [a]peekArray(CharBuffer -> Intforall e. Buffer e -> IntbufferElemsCharBufferto')elsedo-- Input remaining: what went wrong?String -> IO ()putDebugMsg(String"peekEncodedCString: "String -> String -> Stringforall a. [a] -> [a] -> [a]++t -> Stringforall a. Show a => a -> StringshowtiterationString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CodingProgress -> Stringforall a. Show a => a -> StringshowCodingProgresswhy)(Buffer Word8from'',CharBufferto'')<-caseCodingProgresswhyofCodingProgressInvalidSequence->TextDecoder dstate-> Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)forall from to state.BufferCodec from to state-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)recoverTextDecoder dstatedecoderBuffer Word8from'CharBufferto'-- These conditions are equally bad becauseCodingProgressInputUnderflow->TextDecoder dstate-> Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)forall from to state.BufferCodec from to state-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)recoverTextDecoder dstatedecoderBuffer Word8from'CharBufferto'-- they indicate malformed/truncated inputCodingProgressOutputUnderflow->(Buffer Word8, CharBuffer) -> IO (Buffer Word8, CharBuffer)forall (m :: * -> *) a. Monad m => a -> m areturn(Buffer Word8from',CharBufferto')-- We will have more space next time roundString -> IO ()putDebugMsg(String"peekEncodedCString: from "String -> String -> Stringforall a. [a] -> [a] -> [a]++Buffer Word8 -> Stringforall a. Buffer a -> StringsummaryBufferBuffer Word8fromString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++Buffer Word8 -> Stringforall a. Buffer a -> StringsummaryBufferBuffer Word8from'String -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++Buffer Word8 -> Stringforall a. Buffer a -> StringsummaryBufferBuffer Word8from'')String -> IO ()putDebugMsg(String"peekEncodedCString: to "String -> String -> Stringforall a. [a] -> [a] -> [a]++CharBuffer -> Stringforall a. Buffer a -> StringsummaryBufferCharBuffertoString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CharBuffer -> Stringforall a. Buffer a -> StringsummaryBufferCharBufferto'String -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CharBuffer -> Stringforall a. Buffer a -> StringsummaryBufferCharBufferto'')Stringto_chars<-CharBuffer -> (Ptr Char -> IO String) -> IO Stringforall e a. Buffer e -> (Ptr e -> IO a) -> IO awithBufferCharBufferto''((Ptr Char -> IO String) -> IO String)-> (Ptr Char -> IO String) -> IO Stringforall a b. (a -> b) -> a -> b$Int -> Ptr Char -> IO Stringforall a. Storable a => Int -> Ptr a -> IO [a]peekArray(CharBuffer -> Intforall e. Buffer e -> IntbufferElemsCharBufferto'')(String -> String) -> IO String -> IO Stringforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f bfmap(Stringto_charsString -> String -> Stringforall a. [a] -> [a] -> [a]++)(IO String -> IO String) -> IO String -> IO Stringforall a b. (a -> b) -> a -> b$t -> Buffer Word8 -> IO Stringgo(titerationt -> t -> tforall a. Num a => a -> a -> a+t1)Buffer Word8from''Int -> Buffer Word8 -> IO Stringforall t. (Show t, Num t) => t -> Buffer Word8 -> IO Stringgo(Int0::Int)Buffer Word8from0{-# INLINEwithEncodedCString#-}withEncodedCString::TextEncoding-- ^ Encoding of CString to create->Bool-- ^ Null-terminate?->String-- ^ String to encode->(CStringLen->IOa)-- ^ Worker that can safely use the allocated memory->IOawithEncodedCString :: TextEncoding -> Bool -> String -> (CStringLen -> IO a) -> IO awithEncodedCString(TextEncoding{mkTextEncoder :: ()mkTextEncoder=IO (TextEncoder estate)mk_encoder})Boolnull_terminateStringsCStringLen -> IO aact=IO (TextEncoder estate)-> (TextEncoder estate -> IO ())-> (TextEncoder estate -> IO a)-> IO aforall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO cbracketIO (TextEncoder estate)mk_encoderTextEncoder estate -> IO ()forall from to state. BufferCodec from to state -> IO ()close((TextEncoder estate -> IO a) -> IO a)-> (TextEncoder estate -> IO a) -> IO aforall a b. (a -> b) -> a -> b$\TextEncoder estateencoder->String -> (Int -> Ptr Char -> IO a) -> IO aforall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO bwithArrayLenStrings((Int -> Ptr Char -> IO a) -> IO a)-> (Int -> Ptr Char -> IO a) -> IO aforall a b. (a -> b) -> a -> b$\IntszPtr Charp->doCharBufferfrom<-(RawBuffer Char -> CharBuffer)-> IO (RawBuffer Char) -> IO CharBufferforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f bfmap(\RawBuffer Charfp->Int -> CharBuffer -> CharBufferforall e. Int -> Buffer e -> Buffer ebufferAddIntsz(RawBuffer Char -> Int -> BufferState -> CharBufferforall e. RawBuffer e -> Int -> BufferState -> Buffer eemptyBufferRawBuffer CharfpIntszBufferStateReadBuffer))(IO (RawBuffer Char) -> IO CharBuffer)-> IO (RawBuffer Char) -> IO CharBufferforall a b. (a -> b) -> a -> b$Ptr Char -> IO (RawBuffer Char)forall a. Ptr a -> IO (ForeignPtr a)newForeignPtr_Ptr Charpletgo :: t -> Int -> IO ago!titerationIntto_sz_bytes=doString -> IO ()putDebugMsg(String"withEncodedCString: "String -> String -> Stringforall a. [a] -> [a] -> [a]++t -> Stringforall a. Show a => a -> Stringshowtiteration)Int -> (Ptr Word8 -> IO a) -> IO aforall a b. Int -> (Ptr a -> IO b) -> IO ballocaBytesIntto_sz_bytes((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO aforall a b. (a -> b) -> a -> b$\Ptr Word8to_p->doMaybe amb_res<-TextEncoder estate-> Bool-> CharBuffer-> Ptr Word8-> Int-> (CStringLen -> IO a)-> IO (Maybe a)forall dstate a.TextEncoder dstate-> Bool-> CharBuffer-> Ptr Word8-> Int-> (CStringLen -> IO a)-> IO (Maybe a)tryFillBufferAndCallTextEncoder estateencoderBoolnull_terminateCharBufferfromPtr Word8to_pIntto_sz_bytesCStringLen -> IO aactcaseMaybe amb_resofMaybe aNothing->t -> Int -> IO ago(titerationt -> t -> tforall a. Num a => a -> a -> a+t1)(Intto_sz_bytesInt -> Int -> Intforall a. Num a => a -> a -> a*Int2)Justares->a -> IO aforall (m :: * -> *) a. Monad m => a -> m areturnares-- If the input string is ASCII, this value will ensure we only allocate onceInt -> Int -> IO aforall t. (Show t, Num t) => t -> Int -> IO ago(Int0::Int)(IntcCharSizeInt -> Int -> Intforall a. Num a => a -> a -> a*(IntszInt -> Int -> Intforall a. Num a => a -> a -> a+Int1)){-# INLINEnewEncodedCString#-}newEncodedCString::TextEncoding-- ^ Encoding of CString to create->Bool-- ^ Null-terminate?->String-- ^ String to encode->IOCStringLennewEncodedCString :: TextEncoding -> Bool -> String -> IO CStringLennewEncodedCString(TextEncoding{mkTextEncoder :: ()mkTextEncoder=IO (TextEncoder estate)mk_encoder})Boolnull_terminateStrings=IO (TextEncoder estate)-> (TextEncoder estate -> IO ())-> (TextEncoder estate -> IO CStringLen)-> IO CStringLenforall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO cbracketIO (TextEncoder estate)mk_encoderTextEncoder estate -> IO ()forall from to state. BufferCodec from to state -> IO ()close((TextEncoder estate -> IO CStringLen) -> IO CStringLen)-> (TextEncoder estate -> IO CStringLen) -> IO CStringLenforall a b. (a -> b) -> a -> b$\TextEncoder estateencoder->String -> (Int -> Ptr Char -> IO CStringLen) -> IO CStringLenforall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO bwithArrayLenStrings((Int -> Ptr Char -> IO CStringLen) -> IO CStringLen)-> (Int -> Ptr Char -> IO CStringLen) -> IO CStringLenforall a b. (a -> b) -> a -> b$\IntszPtr Charp->doCharBufferfrom<-(RawBuffer Char -> CharBuffer)-> IO (RawBuffer Char) -> IO CharBufferforall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f bfmap(\RawBuffer Charfp->Int -> CharBuffer -> CharBufferforall e. Int -> Buffer e -> Buffer ebufferAddIntsz(RawBuffer Char -> Int -> BufferState -> CharBufferforall e. RawBuffer e -> Int -> BufferState -> Buffer eemptyBufferRawBuffer CharfpIntszBufferStateReadBuffer))(IO (RawBuffer Char) -> IO CharBuffer)-> IO (RawBuffer Char) -> IO CharBufferforall a b. (a -> b) -> a -> b$Ptr Char -> IO (RawBuffer Char)forall a. Ptr a -> IO (ForeignPtr a)newForeignPtr_Ptr Charpletgo :: t -> Ptr Word8 -> Int -> IO CStringLengo!titerationPtr Word8to_pIntto_sz_bytes=doString -> IO ()putDebugMsg(String"newEncodedCString: "String -> String -> Stringforall a. [a] -> [a] -> [a]++t -> Stringforall a. Show a => a -> Stringshowtiteration)Maybe CStringLenmb_res<-TextEncoder estate-> Bool-> CharBuffer-> Ptr Word8-> Int-> (CStringLen -> IO CStringLen)-> IO (Maybe CStringLen)forall dstate a.TextEncoder dstate-> Bool-> CharBuffer-> Ptr Word8-> Int-> (CStringLen -> IO a)-> IO (Maybe a)tryFillBufferAndCallTextEncoder estateencoderBoolnull_terminateCharBufferfromPtr Word8to_pIntto_sz_bytesCStringLen -> IO CStringLenforall (m :: * -> *) a. Monad m => a -> m areturncaseMaybe CStringLenmb_resofMaybe CStringLenNothing->doletto_sz_bytes' :: Intto_sz_bytes'=Intto_sz_bytesInt -> Int -> Intforall a. Num a => a -> a -> a*Int2Ptr Word8to_p'<-Ptr Word8 -> Int -> IO (Ptr Word8)forall a. Ptr a -> Int -> IO (Ptr a)reallocBytesPtr Word8to_pIntto_sz_bytes't -> Ptr Word8 -> Int -> IO CStringLengo(titerationt -> t -> tforall a. Num a => a -> a -> a+t1)Ptr Word8to_p'Intto_sz_bytes'JustCStringLenres->CStringLen -> IO CStringLenforall (m :: * -> *) a. Monad m => a -> m areturnCStringLenres-- If the input string is ASCII, this value will ensure we only allocate onceletto_sz_bytes :: Intto_sz_bytes=IntcCharSizeInt -> Int -> Intforall a. Num a => a -> a -> a*(IntszInt -> Int -> Intforall a. Num a => a -> a -> a+Int1)Ptr Word8to_p<-Int -> IO (Ptr Word8)forall a. Int -> IO (Ptr a)mallocBytesIntto_sz_bytesInt -> Ptr Word8 -> Int -> IO CStringLenforall t. (Show t, Num t) => t -> Ptr Word8 -> Int -> IO CStringLengo(Int0::Int)Ptr Word8to_pIntto_sz_bytestryFillBufferAndCall::TextEncoderdstate->Bool->BufferChar->PtrWord8->Int->(CStringLen->IOa)->IO(Maybea)tryFillBufferAndCall :: TextEncoder dstate-> Bool-> CharBuffer-> Ptr Word8-> Int-> (CStringLen -> IO a)-> IO (Maybe a)tryFillBufferAndCallTextEncoder dstateencoderBoolnull_terminateCharBufferfrom0Ptr Word8to_pIntto_sz_bytesCStringLen -> IO aact=doRawBuffer Word8to_fp<-Ptr Word8 -> IO (RawBuffer Word8)forall a. Ptr a -> IO (ForeignPtr a)newForeignPtr_Ptr Word8to_pInt -> (CharBuffer, Buffer Word8) -> IO (Maybe a)forall a.(Show a, Num a) =>a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)go(Int0::Int)(CharBufferfrom0,RawBuffer Word8 -> Int -> BufferState -> Buffer Word8forall e. RawBuffer e -> Int -> BufferState -> Buffer eemptyBufferRawBuffer Word8to_fpIntto_sz_bytesBufferStateWriteBuffer)wherego :: a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)go!aiteration(CharBufferfrom,Buffer Word8to)=do(CodingProgresswhy,CharBufferfrom',Buffer Word8to')<-TextEncoder dstate -> CodeBuffer Char Word8forall from to state.BufferCodec from to state -> CodeBuffer from toencodeTextEncoder dstateencoderCharBufferfromBuffer Word8toString -> IO ()putDebugMsg(String"tryFillBufferAndCall: "String -> String -> Stringforall a. [a] -> [a] -> [a]++a -> Stringforall a. Show a => a -> StringshowaiterationString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CodingProgress -> Stringforall a. Show a => a -> StringshowCodingProgresswhyString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CharBuffer -> Stringforall a. Buffer a -> StringsummaryBufferCharBufferfromString -> String -> Stringforall a. [a] -> [a] -> [a]++String" "String -> String -> Stringforall a. [a] -> [a] -> [a]++CharBuffer -> Stringforall a. Buffer a -> StringsummaryBufferCharBufferfrom')ifCharBuffer -> Boolforall e. Buffer e -> BoolisEmptyBufferCharBufferfrom'thenifBoolnull_terminateBool -> Bool -> Bool&&Buffer Word8 -> Intforall e. Buffer e -> IntbufferAvailableBuffer Word8to'Int -> Int -> Boolforall a. Eq a => a -> a -> Bool==Int0thenMaybe a -> IO (Maybe a)forall (m :: * -> *) a. Monad m => a -> m areturnMaybe aforall a. Maybe aNothing-- We had enough for the string but not the terminator: ask the caller for more bufferelsedo-- Awesome, we had enough bufferletbytes :: Intbytes=Buffer Word8 -> Intforall e. Buffer e -> IntbufferElemsBuffer Word8to'Buffer Word8 -> (Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a)forall e a. Buffer e -> (Ptr e -> IO a) -> IO awithBufferBuffer Word8to'((Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a))-> (Ptr Word8 -> IO (Maybe a)) -> IO (Maybe a)forall a b. (a -> b) -> a -> b$\Ptr Word8to_ptr->doBool -> IO () -> IO ()forall (f :: * -> *). Applicative f => Bool -> f () -> f ()whenBoolnull_terminate(IO () -> IO ()) -> IO () -> IO ()forall a b. (a -> b) -> a -> b$Ptr Word8 -> Int -> Word8 -> IO ()forall a. Storable a => Ptr a -> Int -> a -> IO ()pokeElemOffPtr Word8to_ptr(Buffer Word8 -> Intforall e. Buffer e -> IntbufRBuffer Word8to')Word80(a -> Maybe a) -> IO a -> IO (Maybe a)forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f bfmapa -> Maybe aforall a. a -> Maybe aJust(IO a -> IO (Maybe a)) -> IO a -> IO (Maybe a)forall a b. (a -> b) -> a -> b$CStringLen -> IO aact(Ptr Word8 -> CStringforall a b. Ptr a -> Ptr bcastPtrPtr Word8to_ptr,Intbytes)-- NB: the length information is specified as being in *bytes*elsecaseCodingProgresswhyof-- We didn't consume all of the inputCodingProgressInputUnderflow->TextEncoder dstate-> CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)forall from to state.BufferCodec from to state-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)recoverTextEncoder dstateencoderCharBufferfrom'Buffer Word8to'IO (CharBuffer, Buffer Word8)-> ((CharBuffer, Buffer Word8) -> IO (Maybe a)) -> IO (Maybe a)forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b>>=a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)go(aiterationa -> a -> aforall a. Num a => a -> a -> a+a1)-- These conditions are equally badCodingProgressInvalidSequence->TextEncoder dstate-> CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)forall from to state.BufferCodec from to state-> Buffer from -> Buffer to -> IO (Buffer from, Buffer to)recoverTextEncoder dstateencoderCharBufferfrom'Buffer Word8to'IO (CharBuffer, Buffer Word8)-> ((CharBuffer, Buffer Word8) -> IO (Maybe a)) -> IO (Maybe a)forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b>>=a -> (CharBuffer, Buffer Word8) -> IO (Maybe a)go(aiterationa -> a -> aforall a. Num a => a -> a -> a+a1)-- since the input was truncated/invalidCodingProgressOutputUnderflow->Maybe a -> IO (Maybe a)forall (m :: * -> *) a. Monad m => a -> m areturnMaybe aforall a. Maybe aNothing-- Oops, out of buffer during decoding: ask the caller for more