diff --git a/Data/Text/ICU/Char.hsc b/Data/Text/ICU/Char.hsc --- a/Data/Text/ICU/Char.hsc +++ b/Data/Text/ICU/Char.hsc @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, ForeignFunctionInterface, - FunctionalDependencies, MultiParamTypeClasses #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, FlexibleInstances, + ForeignFunctionInterface, FunctionalDependencies, MultiParamTypeClasses #-} -- | -- Module : Data.Text.ICU.Char @@ -85,19 +85,16 @@ #include -import Control.Exception (throw) import Data.Char (chr, ord) import Data.Int (Int32) -import Data.Text.ICU.Error (isFailure, u_BUFFER_OVERFLOW_ERROR, - u_INVALID_CHAR_FOUND) -import Data.Text.ICU.Error.Internal (UErrorCode, withError) +import Data.Text.ICU.Error (u_INVALID_CHAR_FOUND) +import Data.Text.ICU.Error.Internal (UErrorCode, handleOverflowError, withError) import Data.Text.ICU.Internal (UBool, UChar32, asBool) import Data.Text.ICU.Normalize.Internal (toNCR) import Data.Typeable (Typeable) import Data.Word (Word8) import Foreign.C.String (CString, peekCStringLen, withCString) import Foreign.C.Types (CInt) -import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Ptr (Ptr) import System.IO.Unsafe (unsafePerformIO) @@ -915,15 +912,8 @@ charName' choice c = fillString $ u_charName (fromIntegral (ord c)) choice fillString :: (CString -> Int32 -> Ptr UErrorCode -> IO Int32) -> String -fillString act = unsafePerformIO $ loop 128 - where - loop n = - allocaBytes n $ \ptr -> do - (err,r) <- withError $ act ptr (fromIntegral n) - case undefined of - _| err == u_BUFFER_OVERFLOW_ERROR -> loop (fromIntegral r) - | isFailure err -> throw err - | otherwise -> peekCStringLen (ptr,fromIntegral r) +fillString act = unsafePerformIO $ + handleOverflowError 83 act (curry peekCStringLen) type UBlockCode = CInt type UCharDirection = CInt diff --git a/Data/Text/ICU/Error/Internal.hsc b/Data/Text/ICU/Error/Internal.hsc --- a/Data/Text/ICU/Error/Internal.hsc +++ b/Data/Text/ICU/Error/Internal.hsc @@ -14,15 +14,18 @@ , isSuccess , errorName , handleError + , handleOverflowError , handleParseError , throwOnError , withError ) where -import Control.Exception (Exception, throw) +import Control.Exception (Exception, throwIO) +import Data.Function (fix) import Foreign.Ptr (Ptr) import Foreign.Marshal.Alloc (alloca) import Foreign.Marshal.Utils (with) +import Foreign.Marshal.Array (allocaArray) import Data.Int (Int32) import Data.Typeable (Typeable) import Foreign.C.String (CString, peekCString) @@ -97,7 +100,7 @@ throwOnError code = do let err = (ICUError code) if isFailure err - then throw err + then throwIO err else return () withError :: (Ptr UErrorCode -> IO a) -> IO (ICUError, a) @@ -114,20 +117,43 @@ throwOnError =<< peek errPtr return ret +-- | Deal with ICU functions that report a buffer overflow error if we +-- give them an insufficiently large buffer. Our first call will +-- report a buffer overflow, in which case we allocate a correctly +-- sized buffer and try again. +handleOverflowError :: (Storable a) => + Int + -- ^ Initial guess at buffer size. + -> (Ptr a -> Int32 -> Ptr UErrorCode -> IO Int32) + -- ^ Function that retrieves data. + -> (Ptr a -> Int -> IO b) + -- ^ Function that fills destination buffer if no + -- overflow occurred. + -> IO b +handleOverflowError guess fill retrieve = + alloca $ \uerrPtr -> flip fix guess $ \loop n -> + (either (loop . fromIntegral) return =<<) . allocaArray n $ \ptr -> do + poke uerrPtr 0 + ret <- fill ptr (fromIntegral n) uerrPtr + err <- peek uerrPtr + case undefined of + _| err == (#const U_BUFFER_OVERFLOW_ERROR) + -> return (Left ret) + | err > 0 -> throwIO (ICUError err) + | otherwise -> Right `fmap` retrieve ptr (fromIntegral ret) + handleParseError :: (ICUError -> Bool) -> (Ptr UParseError -> Ptr UErrorCode -> IO a) -> IO a -handleParseError isParseError action = - with 0 $ \uerrPtr -> - alloca $ \perrPtr -> do - ret <- action perrPtr uerrPtr - err <- ICUError `fmap` peek uerrPtr - if isParseError err - then do - perr <- peek perrPtr - throw perr { errError = err } - else if isFailure err - then throw err - else return ret +handleParseError isParseError action = with 0 $ \uerrPtr -> + alloca $ \perrPtr -> do + ret <- action perrPtr uerrPtr + err <- ICUError `fmap` peek uerrPtr + case undefined of + _| isParseError err -> do + perr <- peek perrPtr + throwIO perr { errError = err } + | isFailure err -> throwIO err + | otherwise -> return ret -- | Return a string representing the name of the given error code. errorName :: ICUError -> String diff --git a/Data/Text/ICU/Normalize.hsc b/Data/Text/ICU/Normalize.hsc --- a/Data/Text/ICU/Normalize.hsc +++ b/Data/Text/ICU/Normalize.hsc @@ -34,20 +34,16 @@ #include #include -import Control.Exception (throw) -import Control.Monad (when) import Data.Text (Text) import Data.Text.Foreign (fromPtr, useAsPtr) -import Data.Text.ICU.Error (u_BUFFER_OVERFLOW_ERROR) -import Data.Text.ICU.Error.Internal (UErrorCode, isFailure, handleError, withError) +import Data.Text.ICU.Error.Internal (UErrorCode, handleError, handleOverflowError) import Data.Text.ICU.Internal (UBool, UChar, asBool, asOrdering) import Data.Text.ICU.Normalize.Internal (UNormalizationCheckResult, toNCR) import Data.Typeable (Typeable) import Data.Int (Int32) import Data.Word (Word32) import Foreign.C.Types (CInt) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, castPtr) import System.IO.Unsafe (unsafePerformIO) import Prelude hiding (compare) import Data.List (foldl') @@ -210,18 +206,9 @@ normalize mode t = unsafePerformIO . useAsPtr t $ \sptr slen -> let slen' = fromIntegral slen mode' = toNM mode - loop dlen = - (either loop return =<<) . - allocaArray dlen $ \dptr -> do - (err, newLen) <- withError $ - unorm_normalize sptr slen' mode' 0 dptr (fromIntegral dlen) - when (isFailure err && err /= u_BUFFER_OVERFLOW_ERROR) $ - throw err - let newLen' = fromIntegral newLen - if newLen' > dlen - then return (Left newLen') - else Right `fmap` fromPtr dptr (fromIntegral newLen') - in loop (fromIntegral slen) + in handleOverflowError (fromIntegral slen) + (\dptr dlen -> unorm_normalize sptr slen' mode' 0 dptr (fromIntegral dlen)) + (\dptr dlen -> fromPtr (castPtr dptr) (fromIntegral dlen)) -- | Perform an efficient check on a string, to quickly determine if diff --git a/Data/Text/ICU/Text.hs b/Data/Text/ICU/Text.hs --- a/Data/Text/ICU/Text.hs +++ b/Data/Text/ICU/Text.hs @@ -22,12 +22,12 @@ import Data.Int (Int32) import Data.Text (Text) import Data.Text.Foreign (fromPtr, useAsPtr) -import Data.Text.ICU.Error.Internal (UErrorCode, handleError) +import Data.Text.ICU.Error.Internal (UErrorCode, handleError, handleOverflowError) import Data.Text.ICU.Internal (LocaleName, UChar, withLocaleName) import Data.Word (Word32) import Foreign.C.String (CString) import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, castPtr) import System.IO.Unsafe (unsafePerformIO) -- $case @@ -63,15 +63,10 @@ caseMap :: CaseMapper -> LocaleName -> Text -> Text caseMap mapFn loc s = unsafePerformIO . withLocaleName loc $ \locale -> - useAsPtr s $ \sptr slen -> do - let go len = allocaArray len $ \dptr -> do - n <- fmap fromIntegral . handleError $ - mapFn dptr (fromIntegral len) sptr - (fromIntegral slen) locale - if n > len - then go n - else fromPtr dptr (fromIntegral n) - go (fromIntegral slen) + useAsPtr s $ \sptr slen -> + handleOverflowError (fromIntegral slen) + (\dptr dlen -> mapFn dptr dlen sptr (fromIntegral slen) locale) + (\dptr dlen -> fromPtr (castPtr dptr) (fromIntegral dlen)) -- | Lowercase the characters in a string. -- diff --git a/text-icu.cabal b/text-icu.cabal --- a/text-icu.cabal +++ b/text-icu.cabal @@ -1,8 +1,8 @@ name: text-icu -version: 0.6.3.3 +version: 0.6.3.4 synopsis: Bindings to the ICU library -homepage: http://bitbucket.org/bos/text-icu -bug-reports: http://bitbucket.org/bos/text-icu/issues +homepage: https://bitbucket.org/bos/text-icu +bug-reports: https://bitbucket.org/bos/text-icu/issues description: Haskell bindings to the International Components for Unicode (ICU) libraries. These libraries provide robust and full-featured Unicode @@ -81,8 +81,8 @@ source-repository head type: mercurial - location: http://bitbucket.org/bos/text-icu + location: https://bitbucket.org/bos/text-icu source-repository head type: git - location: http://github.com/bos/text-icu + location: https://github.com/bos/text-icu