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=FalseputDebugMsg::String->IO()putDebugMsg|c_DEBUG_DUMP=debugLn|otherwise=const(return())-- 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->IOStringpeekCStringenccp=dosz<-lengthArray0nULcppeekEncodedCStringenc(cp,sz*cCharSize)-- | Marshal a C string with explicit length into a Haskell string.--peekCStringLen::TextEncoding->CStringLen->IOStringpeekCStringLen=peekEncodedCString-- | 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->IOCStringnewCStringenc=liftMfst.newEncodedCStringencTrue-- | 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->IOCStringLennewCStringLenenc=newEncodedCStringencFalse-- | 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)->IOawithCStringencsact=withEncodedCStringencTrues$\(cp,_sz)->actcp-- | 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)->IOawithCStringLenenc=withEncodedCStringencFalse-- | 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)->IOawithCStringsLenencstrsf=go[]strswheregocs(s:ss)=withCStringencs$\c->go(c:cs)ssgocs[]=withArrayLen(reversecs)f-- | Determines whether a character can be accurately encoded in a '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!encc=withCStringenc[c](\cstr->dostr<-peekCStringenccstrcasestrof[ch]|ch==c->pureTrue_->pureFalse)`catch`\(_::IOException)->pureFalse-- auxiliary definitions-- ------------------------ C's end of string characternUL::CCharnUL=0-- Size of a CChar in bytescCharSize::IntcCharSize=sizeOf(undefined::CChar){-# INLINEpeekEncodedCString#-}peekEncodedCString::TextEncoding-- ^ Encoding of CString->CStringLen->IOString-- ^ String in Haskell termspeekEncodedCString(TextEncoding{mkTextDecoder=mk_decoder})(p,sz_bytes)=bracketmk_decoderclose$\decoder->doletchunk_size=sz_bytes`max`1-- Decode buffer chunk size in characters: one iteration only for ASCIIfrom0<-fmap(\fp->bufferAddsz_bytes(emptyBufferfpsz_bytesReadBuffer))$newForeignPtr_(castPtrp)to<-newCharBufferchunk_sizeWriteBufferletgoiterationfrom=do(why,from',to')<-encodedecoderfromtoifisEmptyBufferfrom'then-- No input remaining: @why@ will be InputUnderflow, but we don't carewithBufferto'$peekArray(bufferElemsto')elsedo-- Input remaining: what went wrong?putDebugMsg("peekEncodedCString: "++showiteration++" "++showwhy)(from'',to'')<-casewhyofInvalidSequence->recoverdecoderfrom'to'-- These conditions are equally bad becauseInputUnderflow->recoverdecoderfrom'to'-- they indicate malformed/truncated inputOutputUnderflow->return(from',to')-- We will have more space next time roundputDebugMsg("peekEncodedCString: from "++summaryBufferfrom++" "++summaryBufferfrom'++" "++summaryBufferfrom'')putDebugMsg("peekEncodedCString: to "++summaryBufferto++" "++summaryBufferto'++" "++summaryBufferto'')to_chars<-withBufferto''$peekArray(bufferElemsto'')fmap(to_chars++)$go(iteration+1)from''go(0::Int)from0{-# 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{mkTextEncoder=mk_encoder})null_terminatesact=bracketmk_encoderclose$\encoder->withArrayLens$\szp->dofrom<-fmap(\fp->bufferAddsz(emptyBufferfpszReadBuffer))$newForeignPtr_pletgoiterationto_sz_bytes=doputDebugMsg("withEncodedCString: "++showiteration)allocaBytesto_sz_bytes$\to_p->domb_res<-tryFillBufferAndCallencodernull_terminatefromto_pto_sz_bytesactcasemb_resofNothing->go(iteration+1)(to_sz_bytes*2)Justres->returnres-- If the input string is ASCII, this value will ensure we only allocate oncego(0::Int)(cCharSize*(sz+1)){-# INLINEnewEncodedCString#-}newEncodedCString::TextEncoding-- ^ Encoding of CString to create->Bool-- ^ Null-terminate?->String-- ^ String to encode->IOCStringLennewEncodedCString(TextEncoding{mkTextEncoder=mk_encoder})null_terminates=bracketmk_encoderclose$\encoder->withArrayLens$\szp->dofrom<-fmap(\fp->bufferAddsz(emptyBufferfpszReadBuffer))$newForeignPtr_pletgoiterationto_pto_sz_bytes=doputDebugMsg("newEncodedCString: "++showiteration)mb_res<-tryFillBufferAndCallencodernull_terminatefromto_pto_sz_bytesreturncasemb_resofNothing->doletto_sz_bytes'=to_sz_bytes*2to_p'<-reallocBytesto_pto_sz_bytes'go(iteration+1)to_p'to_sz_bytes'Justres->returnres-- If the input string is ASCII, this value will ensure we only allocate onceletto_sz_bytes=cCharSize*(sz+1)to_p<-mallocBytesto_sz_bytesgo(0::Int)to_pto_sz_bytestryFillBufferAndCall::TextEncoderdstate->Bool->BufferChar->PtrWord8->Int->(CStringLen->IOa)->IO(Maybea)tryFillBufferAndCallencodernull_terminatefrom0to_pto_sz_bytesact=doto_fp<-newForeignPtr_to_pgo(0::Int)(from0,emptyBufferto_fpto_sz_bytesWriteBuffer)wheregoiteration(from,to)=do(why,from',to')<-encodeencoderfromtoputDebugMsg("tryFillBufferAndCall: "++showiteration++" "++showwhy++" "++summaryBufferfrom++" "++summaryBufferfrom')ifisEmptyBufferfrom'thenifnull_terminate&&bufferAvailableto'==0thenreturnNothing-- We had enough for the string but not the terminator: ask the caller for more bufferelsedo-- Awesome, we had enough bufferletbytes=bufferElemsto'withBufferto'$\to_ptr->dowhennull_terminate$pokeElemOffto_ptr(bufRto')0fmapJust$act(castPtrto_ptr,bytes)-- NB: the length information is specified as being in *bytes*elsecasewhyof-- We didn't consume all of the inputInputUnderflow->recoverencoderfrom'to'>>=go(iteration+1)-- These conditions are equally badInvalidSequence->recoverencoderfrom'to'>>=go(iteration+1)-- since the input was truncated/invalidOutputUnderflow->returnNothing-- Oops, out of buffer during decoding: ask the caller for more