X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Foreign%2FC%2FString.hs;h=2fb14d0ccf36b328a34f182b902da4f647a3a570;hb=d5f196032673dd07951214ce53c84a904da6eb65;hp=b03d32b5548779a00be183cdf1c12c2802948dc7;hpb=f498141ce5e5bfa843a374e82a6f5f2d0529a4d1;p=ghc-base.git diff --git a/Foreign/C/String.hs b/Foreign/C/String.hs index b03d32b..2fb14d0 100644 --- a/Foreign/C/String.hs +++ b/Foreign/C/String.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# OPTIONS_GHC -XNoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.String @@ -99,7 +99,6 @@ import Data.Word import GHC.List import GHC.Real import GHC.Num -import GHC.IOBase import GHC.Base #else import Data.Char ( chr, ord ) @@ -168,10 +167,8 @@ newCStringLen = newCAStringLen withCString :: String -> (CString -> IO a) -> IO a withCString = withCAString --- | Marshal a Haskell string into a NUL terminated C string using temporary --- storage. --- --- * the Haskell string may /not/ contain any NUL characters +-- | 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 @@ -216,8 +213,8 @@ peekCAString cp = do where loop s i = do xval <- peekElemOff cp i - let val = castCCharToChar xval - val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1) + let val = castCCharToChar xval + val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1) #endif -- | Marshal a C string with explicit length into a Haskell string. @@ -234,11 +231,11 @@ peekCAStringLen (cp, len) where loop acc i = do xval <- peekElemOff cp i - let val = castCCharToChar xval - -- blow away the coercion ASAP. - if (val `seq` (i == 0)) - then return (val:acc) - else loop (val:acc) (i-1) + let val = castCCharToChar xval + -- blow away the coercion ASAP. + if (val `seq` (i == 0)) + then return (val:acc) + else loop (val:acc) (i-1) #endif -- | Marshal a Haskell string into a NUL terminated C string. @@ -256,8 +253,8 @@ newCAString = newArray0 nUL . charsToCChars newCAString str = do ptr <- mallocArray0 (length str) let - go [] n = pokeElemOff ptr n nUL - go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go [] n = pokeElemOff ptr n nUL + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) go str 0 return ptr #endif @@ -271,15 +268,13 @@ newCAString str = do -- newCAStringLen :: String -> IO CStringLen #ifndef __GLASGOW_HASKELL__ -newCAStringLen str = do - a <- newArray (charsToCChars str) - return (pairLength str a) +newCAStringLen str = newArrayLen (charsToCChars str) #else newCAStringLen str = do ptr <- mallocArray0 len let - go [] n = n `seq` return () -- make it strict in n - go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go [] n = n `seq` return () -- make it strict in n + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) go str 0 return (ptr, len) where @@ -302,31 +297,29 @@ withCAString = withArray0 nUL . charsToCChars withCAString str f = allocaArray0 (length str) $ \ptr -> let - go [] n = pokeElemOff ptr n nUL - go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go [] n = pokeElemOff ptr n nUL + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) in do go str 0 f ptr #endif --- | Marshal a Haskell string into a NUL terminated C string using temporary --- storage. --- --- * the Haskell string may /not/ contain any NUL characters +-- | 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. -- withCAStringLen :: String -> (CStringLen -> IO a) -> IO a +withCAStringLen str f = #ifndef __GLASGOW_HASKELL__ -withCAStringLen str act = withArray (charsToCChars str) $ act . pairLength str + withArrayLen (charsToCChars str) $ \ len ptr -> f (ptr, len) #else -withCAStringLen str f = allocaArray len $ \ptr -> let - go [] n = n `seq` return () -- make it strict in n - go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) + go [] n = n `seq` return () -- make it strict in n + go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1) in do go str 0 f (ptr,len) @@ -342,10 +335,11 @@ withCAStringLen str f = nUL :: CChar nUL = 0 --- pair a C string with the length of the given Haskell string --- -pairLength :: String -> a -> (a, Int) -pairLength = flip (,) . length +-- allocate an array to hold the list and pair it with the number of elements +newArrayLen :: Storable a => [a] -> IO (Ptr a, Int) +newArrayLen xs = do + a <- newArray xs + return (a, length xs) #ifndef __GLASGOW_HASKELL__ -- cast [CChar] to [Char] @@ -369,7 +363,7 @@ charsToCChars xs = map castCharToCChar xs -- terminated by NUL. type CWString = Ptr CWchar --- | A wide character string with explicit length information in bytes +-- | A wide character string with explicit length information in 'CWchar's -- instead of a terminating NUL (allowing NUL characters in the middle -- of the string). type CWStringLen = (Ptr CWchar, Int) @@ -407,9 +401,7 @@ newCWString = newArray0 wNUL . charsToCWchars -- 'Foreign.Marshal.Alloc.finalizerFree'. -- newCWStringLen :: String -> IO CWStringLen -newCWStringLen str = do - a <- newArray (charsToCWchars str) - return (pairLength str a) +newCWStringLen str = newArrayLen (charsToCWchars str) -- | Marshal a Haskell string into a NUL terminated C wide string using -- temporary storage. @@ -433,7 +425,8 @@ withCWString = withArray0 wNUL . charsToCWchars -- storage must /not/ be used after this. -- withCWStringLen :: String -> (CWStringLen -> IO a) -> IO a -withCWStringLen str act = withArray (charsToCWchars str) $ act . pairLength str +withCWStringLen str f = + withArrayLen (charsToCWchars str) $ \ len ptr -> f (ptr, len) -- auxiliary definitions -- ---------------------- @@ -444,7 +437,7 @@ wNUL = 0 cWcharsToChars :: [CWchar] -> [Char] charsToCWchars :: [Char] -> [CWchar] -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS -- On Windows, wchar_t is 16 bits wide and CWString uses the UTF-16 encoding. @@ -465,7 +458,7 @@ charsToCWchars = foldr utf16Char [] . map ord fromIntegral (c' `div` 0x400 + 0xd800) : fromIntegral (c' `mod` 0x400 + 0xdc00) : wcs -#else /* !mingw32_TARGET_OS */ +#else /* !mingw32_HOST_OS */ cWcharsToChars xs = map castCWcharToChar xs charsToCWchars xs = map castCharToCWchar xs @@ -479,4 +472,4 @@ castCWcharToChar ch = chr (fromIntegral ch ) castCharToCWchar :: Char -> CWchar castCharToCWchar ch = fromIntegral (ord ch) -#endif /* !mingw32_TARGET_OS */ +#endif /* !mingw32_HOST_OS */