(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude #-}

module Foreign.C.String (

CString, CStringLen,

peekCString, peekCStringLen,

newCString, newCStringLen,

withCString, withCStringLen,

charIsRepresentable,

castCharToCChar, castCCharToChar,

castCharToCUChar, castCUCharToChar, castCharToCSChar, castCSCharToChar,

peekCAString, peekCAStringLen, newCAString, newCAStringLen, withCAString, withCAStringLen,

CWString, CWStringLen,

peekCWString, peekCWStringLen, newCWString, newCWStringLen, withCWString, withCWStringLen,

) where

import Foreign.Marshal.Array import Foreign.C.Types import Foreign.Ptr import Foreign.Storable

import Data.Word

import GHC.Char import GHC.List import GHC.Real import GHC.Num import GHC.Base

import {-# SOURCE #-} GHC.IO.Encoding import qualified GHC.Foreign as GHC

type CString = Ptr CChar

type CStringLen = (Ptr CChar, Int)

peekCString :: CString -> IO String peekCString :: CString -> IO String peekCString CString s = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO String) -> IO String forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TextEncoding -> CString -> IO String) -> CString -> TextEncoding -> IO String forall a b c. (a -> b -> c) -> b -> a -> c flip TextEncoding -> CString -> IO String GHC.peekCString CString s

peekCStringLen :: CStringLen -> IO String peekCStringLen :: CStringLen -> IO String peekCStringLen CStringLen s = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO String) -> IO String forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TextEncoding -> CStringLen -> IO String) -> CStringLen -> TextEncoding -> IO String forall a b c. (a -> b -> c) -> b -> a -> c flip TextEncoding -> CStringLen -> IO String GHC.peekCStringLen CStringLen s

newCString :: String -> IO CString newCString :: String -> IO CString newCString String s = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO CString) -> IO CString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TextEncoding -> String -> IO CString) -> String -> TextEncoding -> IO CString forall a b c. (a -> b -> c) -> b -> a -> c flip TextEncoding -> String -> IO CString GHC.newCString String s

newCStringLen :: String -> IO CStringLen newCStringLen :: String -> IO CStringLen newCStringLen String s = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO CStringLen) -> IO CStringLen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TextEncoding -> String -> IO CStringLen) -> String -> TextEncoding -> IO CStringLen forall a b c. (a -> b -> c) -> b -> a -> c flip TextEncoding -> String -> IO CStringLen GHC.newCStringLen String s

withCString :: String -> (CString -> IO a) -> IO a withCString :: forall a. String -> (CString -> IO a) -> IO a withCString String s CString -> IO a f = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO a) -> IO a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \TextEncoding enc -> TextEncoding -> String -> (CString -> IO a) -> IO a forall a. TextEncoding -> String -> (CString -> IO a) -> IO a GHC.withCString TextEncoding enc String s CString -> IO a f

withCStringLen :: String -> (CStringLen -> IO a) -> IO a withCStringLen :: forall a. String -> (CStringLen -> IO a) -> IO a withCStringLen String s CStringLen -> IO a f = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO a) -> IO a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \TextEncoding enc -> TextEncoding -> String -> (CStringLen -> IO a) -> IO a forall a. TextEncoding -> String -> (CStringLen -> IO a) -> IO a GHC.withCStringLen TextEncoding enc String s CStringLen -> IO a f

charIsRepresentable :: Char -> IO Bool charIsRepresentable :: Char -> IO Bool charIsRepresentable Char c = IO TextEncoding getForeignEncoding IO TextEncoding -> (TextEncoding -> IO Bool) -> IO Bool forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (TextEncoding -> Char -> IO Bool) -> Char -> TextEncoding -> IO Bool forall a b c. (a -> b -> c) -> b -> a -> c flip TextEncoding -> Char -> IO Bool GHC.charIsRepresentable Char c

castCCharToChar :: CChar -> Char castCCharToChar :: CChar -> Char castCCharToChar CChar ch = Int -> Char unsafeChr (Word8 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (CChar -> Word8 forall a b. (Integral a, Num b) => a -> b fromIntegral CChar ch :: Word8))

castCharToCChar :: Char -> CChar castCharToCChar :: Char -> CChar castCharToCChar Char ch = Int -> CChar forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char ch)

castCUCharToChar :: CUChar -> Char castCUCharToChar :: CUChar -> Char castCUCharToChar CUChar ch = Int -> Char unsafeChr (Word8 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (CUChar -> Word8 forall a b. (Integral a, Num b) => a -> b fromIntegral CUChar ch :: Word8))

castCharToCUChar :: Char -> CUChar castCharToCUChar :: Char -> CUChar castCharToCUChar Char ch = Int -> CUChar forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char ch)

castCSCharToChar :: CSChar -> Char castCSCharToChar :: CSChar -> Char castCSCharToChar CSChar ch = Int -> Char unsafeChr (Word8 -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral (CSChar -> Word8 forall a b. (Integral a, Num b) => a -> b fromIntegral CSChar ch :: Word8))

castCharToCSChar :: Char -> CSChar castCharToCSChar :: Char -> CSChar castCharToCSChar Char ch = Int -> CSChar forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char ch)

peekCAString :: CString -> IO String peekCAString :: CString -> IO String peekCAString CString cp = do Int l <- CChar -> CString -> IO Int forall a. (Storable a, Eq a) => a -> Ptr a -> IO Int lengthArray0 CChar nUL CString cp if Int l Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 0 then String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return String "" else String -> Int -> IO String loop String "" (Int lInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) where loop :: String -> Int -> IO String loop String s Int i = do CChar xval <- CString -> Int -> IO CChar forall a. Storable a => Ptr a -> Int -> IO a peekElemOff CString cp Int i let val :: Char val = CChar -> Char castCCharToChar CChar xval Char val Char -> IO String -> IO String seq if Int i Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 0 then String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return (Char valChar -> String -> String forall a. a -> [a] -> [a] :String s) else String -> Int -> IO String loop (Char valChar -> String -> String forall a. a -> [a] -> [a] :String s) (Int iInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1)

peekCAStringLen :: CStringLen -> IO String peekCAStringLen :: CStringLen -> IO String peekCAStringLen (CString cp, Int len) | Int len Int -> Int -> Bool forall a. Ord a => a -> a -> Bool <= Int 0 = String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return String "" | Bool otherwise = String -> Int -> IO String loop [] (Int lenInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1) where loop :: String -> Int -> IO String loop String acc Int i = do CChar xval <- CString -> Int -> IO CChar forall a. Storable a => Ptr a -> Int -> IO a peekElemOff CString cp Int i let val :: Char val = CChar -> Char castCCharToChar CChar xval

     if (Char

val Char -> Bool -> Bool seq (Int i Int -> Int -> Bool forall a. Eq a => a -> a -> Bool == Int 0)) then String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return (Char valChar -> String -> String forall a. a -> [a] -> [a] :String acc) else String -> Int -> IO String loop (Char valChar -> String -> String forall a. a -> [a] -> [a] :String acc) (Int iInt -> Int -> Int forall a. Num a => a -> a -> a -Int 1)

newCAString :: String -> IO CString newCAString :: String -> IO CString newCAString String str = do CString ptr <- Int -> IO CString forall a. Storable a => Int -> IO (Ptr a) mallocArray0 (String -> Int forall a. [a] -> Int length String str) let go :: String -> Int -> IO () go [] Int n = CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n CChar nUL go (Char c:String cs) Int n = do CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n (Char -> CChar castCharToCChar Char c); String -> Int -> IO () go String cs (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) String -> Int -> IO () go String str Int 0 CString -> IO CString forall (m :: * -> *) a. Monad m => a -> m a return CString ptr

newCAStringLen :: String -> IO CStringLen newCAStringLen :: String -> IO CStringLen newCAStringLen String str = do CString ptr <- Int -> IO CString forall a. Storable a => Int -> IO (Ptr a) mallocArray0 Int len let go :: String -> Int -> IO () go [] Int n = Int n Int -> IO () -> IO () seq () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () go (Char c:String cs) Int n = do CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n (Char -> CChar castCharToCChar Char c); String -> Int -> IO () go String cs (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) String -> Int -> IO () go String str Int 0 CStringLen -> IO CStringLen forall (m :: * -> *) a. Monad m => a -> m a return (CString ptr, Int len) where len :: Int len = String -> Int forall a. [a] -> Int length String str

withCAString :: String -> (CString -> IO a) -> IO a withCAString :: forall a. String -> (CString -> IO a) -> IO a withCAString String str CString -> IO a f = Int -> (CString -> IO a) -> IO a forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b allocaArray0 (String -> Int forall a. [a] -> Int length String str) ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a forall a b. (a -> b) -> a -> b $ \CString ptr -> let go :: String -> Int -> IO () go [] Int n = CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n CChar nUL go (Char c:String cs) Int n = do CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n (Char -> CChar castCharToCChar Char c); String -> Int -> IO () go String cs (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) in do String -> Int -> IO () go String str Int 0 CString -> IO a f CString ptr

withCAStringLen :: String -> (CStringLen -> IO a) -> IO a withCAStringLen :: forall a. String -> (CStringLen -> IO a) -> IO a withCAStringLen String str CStringLen -> IO a f = Int -> (CString -> IO a) -> IO a forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b allocaArray Int len ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a forall a b. (a -> b) -> a -> b $ \CString ptr -> let go :: String -> Int -> IO () go [] Int n = Int n Int -> IO () -> IO () seq () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () go (Char c:String cs) Int n = do CString -> Int -> CChar -> IO () forall a. Storable a => Ptr a -> Int -> a -> IO () pokeElemOff CString ptr Int n (Char -> CChar castCharToCChar Char c); String -> Int -> IO () go String cs (Int nInt -> Int -> Int forall a. Num a => a -> a -> a +Int 1) in do String -> Int -> IO () go String str Int 0 CStringLen -> IO a f (CString ptr,Int len) where len :: Int len = String -> Int forall a. [a] -> Int length String str

nUL :: CChar nUL :: CChar nUL = CChar 0

newArrayLen :: Storable a => [a] -> IO (Ptr a, Int) newArrayLen :: forall a. Storable a => [a] -> IO (Ptr a, Int) newArrayLen [a] xs = do Ptr a a <- [a] -> IO (Ptr a) forall a. Storable a => [a] -> IO (Ptr a) newArray [a] xs (Ptr a, Int) -> IO (Ptr a, Int) forall (m :: * -> *) a. Monad m => a -> m a return (Ptr a a, [a] -> Int forall a. [a] -> Int length [a] xs)

type CWString = Ptr CWchar

type CWStringLen = (Ptr CWchar, Int)

peekCWString :: CWString -> IO String peekCWString :: CWString -> IO String peekCWString CWString cp = do [CWchar] cs <- CWchar -> CWString -> IO [CWchar] forall a. (Storable a, Eq a) => a -> Ptr a -> IO [a] peekArray0 CWchar wNUL CWString cp String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return ([CWchar] -> String cWcharsToChars [CWchar] cs)

peekCWStringLen :: CWStringLen -> IO String peekCWStringLen :: CWStringLen -> IO String peekCWStringLen (CWString cp, Int len) = do [CWchar] cs <- Int -> CWString -> IO [CWchar] forall a. Storable a => Int -> Ptr a -> IO [a] peekArray Int len CWString cp String -> IO String forall (m :: * -> *) a. Monad m => a -> m a return ([CWchar] -> String cWcharsToChars [CWchar] cs)

newCWString :: String -> IO CWString newCWString :: String -> IO CWString newCWString = CWchar -> [CWchar] -> IO CWString forall a. Storable a => a -> [a] -> IO (Ptr a) newArray0 CWchar wNUL ([CWchar] -> IO CWString) -> (String -> [CWchar]) -> String -> IO CWString forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> [CWchar] charsToCWchars

newCWStringLen :: String -> IO CWStringLen newCWStringLen :: String -> IO CWStringLen newCWStringLen String str = [CWchar] -> IO CWStringLen forall a. Storable a => [a] -> IO (Ptr a, Int) newArrayLen (String -> [CWchar] charsToCWchars String str)

withCWString :: String -> (CWString -> IO a) -> IO a withCWString :: forall a. String -> (CWString -> IO a) -> IO a withCWString = CWchar -> [CWchar] -> (CWString -> IO a) -> IO a forall a b. Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b withArray0 CWchar wNUL ([CWchar] -> (CWString -> IO a) -> IO a) -> (String -> [CWchar]) -> String -> (CWString -> IO a) -> IO a forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> [CWchar] charsToCWchars

withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a withCWStringLen :: forall a. String -> (CWStringLen -> IO a) -> IO a withCWStringLen String str CWStringLen -> IO a f = [CWchar] -> (Int -> CWString -> IO a) -> IO a forall a b. Storable a => [a] -> (Int -> Ptr a -> IO b) -> IO b withArrayLen (String -> [CWchar] charsToCWchars String str) ((Int -> CWString -> IO a) -> IO a) -> (Int -> CWString -> IO a) -> IO a forall a b. (a -> b) -> a -> b $ \ Int len CWString ptr -> CWStringLen -> IO a f (CWString ptr, Int len)

wNUL :: CWchar wNUL :: CWchar wNUL = CWchar 0

cWcharsToChars :: [CWchar] -> [Char] charsToCWchars :: [Char] -> [CWchar]

#if defined(mingw32_HOST_OS)

cWcharsToChars = map chr . fromUTF16 . map fromIntegral where fromUTF16 (c1:c2:wcs) | 0xd800 <= c1 && c1 <= 0xdbff && 0xdc00 <= c2 && c2 <= 0xdfff = ((c1 - 0xd800)*0x400 + (c2 - 0xdc00) + 0x10000) : fromUTF16 wcs fromUTF16 (c:wcs) = c : fromUTF16 wcs fromUTF16 [] = []

charsToCWchars = foldr utf16Char [] . map ord where utf16Char c wcs | c < 0x10000 = fromIntegral c : wcs | otherwise = let c' = c - 0x10000 in fromIntegral (c' div 0x400 + 0xd800) : fromIntegral (c' mod 0x400 + 0xdc00) : wcs

#else /* !mingw32_HOST_OS */

cWcharsToChars :: [CWchar] -> String cWcharsToChars [CWchar] xs = (CWchar -> Char) -> [CWchar] -> String forall a b. (a -> b) -> [a] -> [b] map CWchar -> Char castCWcharToChar [CWchar] xs charsToCWchars :: String -> [CWchar] charsToCWchars String xs = (Char -> CWchar) -> String -> [CWchar] forall a b. (a -> b) -> [a] -> [b] map Char -> CWchar castCharToCWchar String xs

castCWcharToChar :: CWchar -> Char castCWcharToChar :: CWchar -> Char castCWcharToChar CWchar ch = Int -> Char chr (CWchar -> Int forall a b. (Integral a, Num b) => a -> b fromIntegral CWchar ch )

castCharToCWchar :: Char -> CWchar castCharToCWchar :: Char -> CWchar castCharToCWchar Char ch = Int -> CWchar forall a b. (Integral a, Num b) => a -> b fromIntegral (Char -> Int ord Char ch)

#endif /* !mingw32_HOST_OS */