GHC/Foreign.hs

   1 {-# LANGUAGE CPP, NoImplicitPrelude #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Encoding
   6 -- Copyright   :  (c) The University of Glasgow, 2008-2011
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  libraries@haskell.org
  10 -- Stability   :  internal
  11 -- Portability :  non-portable
  12 --
  13 -- Foreign marshalling support for CStrings with configurable encodings
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module GHC.Foreign (
  18     -- * C strings with a configurable encoding
  19
  20     -- conversion of C strings into Haskell strings
  21     --
  22     peekCString,       -- :: TextEncoding -> CString    -> IO String
  23     peekCStringLen,    -- :: TextEncoding -> CStringLen -> IO String
  24
  25     -- conversion of Haskell strings into C strings
  26     --
  27     newCString,        -- :: TextEncoding -> String -> IO CString
  28     newCStringLen,     -- :: TextEncoding -> String -> IO CStringLen
  29
  30     -- conversion of Haskell strings into C strings using temporary storage
  31     --
  32     withCString,       -- :: TextEncoding -> String -> (CString    -> IO a) -> IO a
  33     withCStringLen,    -- :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
  34
  35     charIsRepresentable, -- :: TextEncoding -> Char -> IO Bool
  36   ) where
  37
  38 import Foreign.Marshal.Array
  39 import Foreign.C.Types
  40 import Foreign.Ptr
  41 import Foreign.Storable
  42
  43 import Data.Word
  44
  45 -- Imports for the locale-encoding version of marshallers
  46 import Control.Monad
  47
  48 import Data.Tuple (fst)
  49 import Data.Maybe
  50
  51 import {-# SOURCE #-} System.Posix.Internals (puts)
  52 import GHC.Show ( show )
  53
  54 import Foreign.Marshal.Alloc
  55 import Foreign.ForeignPtr
  56
  57 import GHC.Err (undefined)
  58 import GHC.List
  59 import GHC.Num
  60 import GHC.Base
  61
  62 import GHC.IO
  63 import GHC.IO.Exception
  64 import GHC.IO.Buffer
  65 import GHC.IO.Encoding.Types
  66
  67
  68 c_DEBUG_DUMP :: Bool
  69 c_DEBUG_DUMP = False
  70
  71 putDebugMsg :: String -> IO ()
  72 putDebugMsg | c_DEBUG_DUMP = puts
  73             | otherwise    = const (return ())
  74
  75
  76 -- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle:
  77 type CString    = Ptr CChar
  78 type CStringLen = (Ptr CChar, Int)
  79
  80 -- exported functions
  81 -- ------------------
  82
  83 -- | Marshal a NUL terminated C string into a Haskell string.
  84 --
  85 peekCString    :: TextEncoding -> CString -> IO String
  86 peekCString enc cp = do
  87     sz <- lengthArray0 nUL cp
  88     peekEncodedCString enc (cp, sz * cCharSize)
  89
  90 -- | Marshal a C string with explicit length into a Haskell string.
  91 --
  92 peekCStringLen           :: TextEncoding -> CStringLen -> IO String
  93 peekCStringLen = peekEncodedCString
  94
  95 -- | Marshal a Haskell string into a NUL terminated C string.
  96 --
  97 -- * the Haskell string may /not/ contain any NUL characters
  98 --
  99 -- * new storage is allocated for the C string and must be
 100 --   explicitly freed using 'Foreign.Marshal.Alloc.free' or
 101 --   'Foreign.Marshal.Alloc.finalizerFree'.
 102 --
 103 newCString :: TextEncoding -> String -> IO CString
 104 newCString enc = liftM fst . newEncodedCString enc True
 105
 106 -- | Marshal a Haskell string into a C string (ie, character array) with
 107 -- explicit length information.
 108 --
 109 -- * new storage is allocated for the C string and must be
 110 --   explicitly freed using 'Foreign.Marshal.Alloc.free' or
 111 --   'Foreign.Marshal.Alloc.finalizerFree'.
 112 --
 113 newCStringLen     :: TextEncoding -> String -> IO CStringLen
 114 newCStringLen enc = newEncodedCString enc False
 115
 116 -- | Marshal a Haskell string into a NUL terminated C string using temporary
 117 -- storage.
 118 --
 119 -- * the Haskell string may /not/ contain any NUL characters
 120 --
 121 -- * the memory is freed when the subcomputation terminates (either
 122 --   normally or via an exception), so the pointer to the temporary
 123 --   storage must /not/ be used after this.
 124 --
 125 withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a
 126 withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp
 127
 128 -- | Marshal a Haskell string into a C string (ie, character array)
 129 -- in temporary storage, with explicit length information.
 130 --
 131 -- * the memory is freed when the subcomputation terminates (either
 132 --   normally or via an exception), so the pointer to the temporary
 133 --   storage must /not/ be used after this.
 134 --
 135 withCStringLen         :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a
 136 withCStringLen enc = withEncodedCString enc False
 137
 138
 139 -- | Determines whether a character can be accurately encoded in a 'CString'.
 140 --
 141 -- Pretty much anyone who uses this function is in a state of sin because
 142 -- whether or not a character is encodable will, in general, depend on the
 143 -- context in which it occurs.
 144 charIsRepresentable :: TextEncoding -> Char -> IO Bool
 145 charIsRepresentable enc c = withCString enc [c] (fmap (== [c]) . peekCString enc) `catchException` (\e -> let _ = e :: IOException in return False)
 146
 147 -- auxiliary definitions
 148 -- ----------------------
 149
 150 -- C's end of string character
 151 nUL :: CChar
 152 nUL  = 0
 153
 154 -- Size of a CChar in bytes
 155 cCharSize :: Int
 156 cCharSize = sizeOf (undefined :: CChar)
 157
 158
 159 {-# INLINE peekEncodedCString #-}
 160 peekEncodedCString :: TextEncoding -- ^ Encoding of CString
 161                    -> CStringLen
 162                    -> IO String    -- ^ String in Haskell terms
 163 peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)
 164   = bracket mk_decoder close $ \decoder -> do
 165       let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII
 166       from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p)
 167       to <- newCharBuffer chunk_size WriteBuffer
 168
 169       let go iteration from = do
 170             (why, from', to') <- encode decoder from to
 171             if isEmptyBuffer from'
 172              then
 173               -- No input remaining: @why@ will be InputUnderflow, but we don't care
 174               withBuffer to' $ peekArray (bufferElems to')
 175              else do
 176               -- Input remaining: what went wrong?
 177               putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why)
 178               (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because
 179                                             InputUnderflow  -> recover decoder from' to' -- they indicate malformed/truncated input
 180                                             OutputUnderflow -> return (from', to')       -- We will have more space next time round
 181               putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'')
 182               putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'')
 183               to_chars <- withBuffer to'' $ peekArray (bufferElems to'')
 184               fmap (to_chars++) $ go (iteration + 1) from''
 185
 186       go (0 :: Int) from0
 187
 188 {-# INLINE withEncodedCString #-}
 189 withEncodedCString :: TextEncoding         -- ^ Encoding of CString to create
 190                    -> Bool                 -- ^ Null-terminate?
 191                    -> String               -- ^ String to encode
 192                    -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory
 193                    -> IO a
 194 withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act
 195   = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
 196       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p
 197
 198       let go iteration to_sz_bytes = do
 199            putDebugMsg ("withEncodedCString: " ++ show iteration)
 200            allocaBytes to_sz_bytes $ \to_p -> do
 201             mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes act
 202             case mb_res of
 203               Nothing  -> go (iteration + 1) (to_sz_bytes * 2)
 204               Just res -> return res
 205
 206       -- If the input string is ASCII, this value will ensure we only allocate once
 207       go (0 :: Int) (cCharSize * (sz + 1))
 208
 209 {-# INLINE newEncodedCString #-}
 210 newEncodedCString :: TextEncoding  -- ^ Encoding of CString to create
 211                   -> Bool          -- ^ Null-terminate?
 212                   -> String        -- ^ String to encode
 213                   -> IO CStringLen
 214 newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s
 215   = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
 216       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p
 217
 218       let go iteration to_p to_sz_bytes = do
 219            putDebugMsg ("newEncodedCString: " ++ show iteration)
 220            mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes return
 221            case mb_res of
 222              Nothing  -> do
 223                  let to_sz_bytes' = to_sz_bytes * 2
 224                  to_p' <- reallocBytes to_p to_sz_bytes'
 225                  go (iteration + 1) to_p' to_sz_bytes'
 226              Just res -> return res
 227
 228       -- If the input string is ASCII, this value will ensure we only allocate once
 229       let to_sz_bytes = cCharSize * (sz + 1)
 230       to_p <- mallocBytes to_sz_bytes
 231       go (0 :: Int) to_p to_sz_bytes
 232
 233
 234 tryFillBufferAndCall :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int
 235                      -> (CStringLen -> IO a) -> IO (Maybe a)
 236 tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do
 237     to_fp <- newForeignPtr_ to_p
 238     go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer)
 239   where
 240     go iteration (from, to) = do
 241       (why, from', to') <- encode encoder from to
 242       putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from')
 243       if isEmptyBuffer from'
 244        then if null_terminate && bufferAvailable to' == 0
 245              then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer
 246              else do
 247                -- Awesome, we had enough buffer
 248                let bytes = bufferElems to'
 249                withBuffer to' $ \to_ptr -> do
 250                    when null_terminate $ pokeElemOff to_ptr (bufR to') 0
 251                    fmap Just $ act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes*
 252        else case why of -- We didn't consume all of the input
 253               InputUnderflow  -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad
 254               InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid
 255               OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more