diff --git a/Data/Text/ICU.hs b/Data/Text/ICU.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +-- | +-- Module : Data.Text.ICU +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Commonly used functions for Unicode, implemented as bindings to the +-- International Components for Unicode (ICU) libraries. +-- +-- This module contains only the most commonly used types and +-- functions. Other modules in this package expose richer interfaces. +module Data.Text.ICU + ( + -- * Data representation + -- $data + + -- * Types + LocaleName(..) + -- * Case mapping + , toCaseFold + , toLower + , toUpper + -- * Iteration + , CharIterator + , fromString + , fromText + , fromUtf8 + -- * Normalization + , NormalizationMode(..) + , normalize + , quickCheck + , isNormalized + -- * String comparison + -- ** Normalization-sensitive string comparison + , CompareOption(..) + , compare + -- ** Locale-sensitive string collation + -- $collate + , Collator + , collator + , collate + , collateIter + , sortKey + , uca + ) where + +import Data.Text.ICU.Collate.Pure +import Data.Text.ICU.Internal +import Data.Text.ICU.Iterator +import Data.Text.ICU.Normalize +import Data.Text.ICU.Text +#if defined(__HADDOCK__) +import Data.Text.Foreign +import Data.Text (Text) +#endif + +-- $data +-- +-- The Haskell 'Text' type is implemented as an array in the Haskell +-- heap. This means that its location is not pinned; it may be copied +-- during a garbage collection pass. ICU, on the other hand, works +-- with strings that are allocated in the normal system heap and have +-- a fixed address. +-- +-- To accommodate this need, these bindings use the functions from +-- 'Data.Text.Foreign' to copy data between the Haskell heap and the +-- system heap. The copied strings are still managed automatically, +-- but the need to duplicate data does add some performance and memory +-- overhead. + +-- $collate +-- +-- For the impure collation API (which is richer, but less easy to +-- use than the pure API), see the 'Data.Text.ICU.Collate' +-- module. diff --git a/Data/Text/ICU/Break.hsc b/Data/Text/ICU/Break.hsc new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Break.hsc @@ -0,0 +1,224 @@ +{-# LANGUAGE BangPatterns, EmptyDataDecls, ForeignFunctionInterface #-} +-- | +-- Module : Data.Text.ICU.Break +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- String breaking functions for Unicode, implemented as bindings to +-- the International Components for Unicode (ICU) libraries. +-- +-- The text boundary positions are found according to the rules described in +-- Unicode Standard Annex #29, Text Boundaries, and Unicode Standard Annex +-- #14, Line Breaking Properties. These are available at +-- and +-- . + +module Data.Text.ICU.Break + ( + -- * Types + BreakIterator + , Line(..) + , Word(..) + -- * Breaking functions + , breakCharacter + , breakLine + , breakSentence + , breakWord + , setText + -- * Iteration functions + , first + , last + , next + , previous + , getStatus + , getStatuses + ) where + +#include + +import Data.Int (Int32) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text.Foreign (dropWord16, takeWord16, useAsPtr) +import Data.Text.ICU.Error.Internal (UErrorCode, handleError) +import Data.Text.ICU.Internal (LocaleName, UChar, withLocaleName) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Marshal.Array (allocaArray, peekArray) +import Foreign.Ptr (FunPtr, Ptr, nullPtr) +import Prelude hiding (last) + +-- | Line break status. +data Line = Soft -- ^ A soft line break is a position at + -- which a line break is acceptable, but not + -- required. + | Hard + deriving (Eq, Show, Enum) + +-- | Word break status. +data Word = Uncategorized -- ^ A "word" that does not fit into another + -- category. Includes spaces and most + -- punctuation. + | Number -- ^ A word that appears to be a number. + | Letter -- ^ A word containing letters, excluding + -- hiragana, katakana or ideographic + -- characters. + | Kana -- ^ A word containing kana characters. + | Ideograph -- ^ A word containing ideographic characters. + deriving (Eq, Show, Enum) + +-- A break iterator. +data BreakIterator a = BI (IORef Text) (Int32 -> a) (ForeignPtr UBreakIterator) + +-- | Break a string on character boundaries. +-- +-- Character boundary analysis identifies the boundaries of "Extended +-- Grapheme Clusters", which are groupings of codepoints that should be +-- treated as character-like units for many text operations. Please see +-- Unicode Standard Annex #29, Unicode Text Segmentation, +-- for additional information on +-- grapheme clusters and guidelines on their use. +breakCharacter :: LocaleName -> Text -> IO (BreakIterator ()) +breakCharacter = open (#const UBRK_CHARACTER) (const ()) + +-- | Break a string on line boundaries. +-- +-- Line boundary analysis determines where a text string can be broken when +-- line wrapping. The mechanism correctly handles punctuation and hyphenated +-- words. +breakLine :: LocaleName -> Text -> IO (BreakIterator Line) +breakLine = open (#const UBRK_LINE) asLine + where + asLine i + | i < (#const UBRK_LINE_SOFT_LIMIT) = Soft + | i < (#const UBRK_LINE_HARD_LIMIT) = Hard + | otherwise = error $ "unknown line break status " ++ show i + +-- | Break a string on sentence boundaries. +-- +-- Sentence boundary analysis allows selection with correct interpretation +-- of periods within numbers and abbreviations, and trailing punctuation +-- marks such as quotation marks and parentheses. +breakSentence :: LocaleName -> Text -> IO (BreakIterator ()) +breakSentence = open (#const UBRK_SENTENCE) (const ()) + +-- | Break a string on word boundaries. +-- +-- Word boundary analysis is used by search and replace functions, as well +-- as within text editing applications that allow the user to select words +-- with a double click. Word selection provides correct interpretation of +-- punctuation marks within and following words. Characters that are not +-- part of a word, such as symbols or punctuation marks, have word breaks on +-- both sides. +breakWord :: LocaleName -> Text -> IO (BreakIterator Word) +breakWord = open (#const UBRK_WORD) asWord + where + asWord i + | i < (#const UBRK_WORD_NONE_LIMIT) = Uncategorized + | i < (#const UBRK_WORD_NUMBER_LIMIT) = Number + | i < (#const UBRK_WORD_LETTER_LIMIT) = Letter + | i < (#const UBRK_WORD_KANA_LIMIT) = Kana + | i < (#const UBRK_WORD_IDEO_LIMIT) = Ideograph + | otherwise = error $ "unknown word break status " ++ show i + +-- | Create a new 'BreakIterator' for locating text boundaries in the +-- specified locale. +open :: UBreakIteratorType -> (Int32 -> a) -> LocaleName -> Text + -> IO (BreakIterator a) +open brk f loc t = withLocaleName loc $ \locale -> + useAsPtr t $ \ptr len -> do + bi <- handleError $ ubrk_open brk locale ptr (fromIntegral len) + r <- newIORef t + BI r f `fmap` newForeignPtr ubrk_close bi + +-- | Point an existing 'BreakIterator' at a new piece of text. +setText :: BreakIterator a -> Text -> IO () +setText (BI r _ bi) t = + useAsPtr t $ \ptr len -> do + withForeignPtr bi $ \p -> handleError $ + ubrk_setText p ptr (fromIntegral len) + writeIORef r t + +asIndex :: (Ptr UBreakIterator -> IO Int32) -> BreakIterator a + -> IO (Maybe (Text, Text)) +asIndex act (BI r _ bi) = do + ix <- withForeignPtr bi act + if ix == (#const UBRK_DONE) + then return Nothing + else do + let n = fromIntegral ix + t <- readIORef r + return $! Just (takeWord16 n t, dropWord16 n t) + +-- | Reset the iterator and break at the first character in the text being +-- scanned. +first :: BreakIterator a -> IO (Maybe (Text, Text)) +first = asIndex ubrk_first + +-- | Reset the iterator and break immediately /beyond/ the last character in +-- the text being scanned. +last :: BreakIterator a -> IO (Maybe (Text, Text)) +last = asIndex ubrk_last + +-- | Advance the iterator and break at the text boundary that follows the +-- current text boundary. +next :: BreakIterator a -> IO (Maybe (Text, Text)) +next = asIndex ubrk_next + +-- | Advance the iterator and break at the text boundary that precedes the +-- current text boundary. +previous :: BreakIterator a -> IO (Maybe (Text, Text)) +previous = asIndex ubrk_previous + +-- | Return the status from the break rule that determined the most recently +-- returned break position. For rules that do not specify a status, a +-- default value of @()@ is returned. +getStatus :: BreakIterator a -> IO a +getStatus (BI _ f bi) = f `fmap` withForeignPtr bi ubrk_getRuleStatus + +-- | Return statuses from all of the break rules that determined the most +-- recently returned break position. +getStatuses :: BreakIterator a -> IO [a] +getStatuses (BI _ f bi) = + withForeignPtr bi $ \brk -> do + n <- handleError $ ubrk_getRuleStatusVec brk nullPtr 0 + allocaArray (fromIntegral n) $ \ptr -> do + _ <- handleError $ ubrk_getRuleStatusVec brk ptr n + map f `fmap` peekArray (fromIntegral n) ptr + +type UBreakIteratorType = CInt +data UBreakIterator + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_open" ubrk_open + :: UBreakIteratorType -> CString -> Ptr UChar -> Int32 -> Ptr UErrorCode + -> IO (Ptr UBreakIterator) + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_setText" ubrk_setText + :: Ptr UBreakIterator -> Ptr UChar -> Int32 -> Ptr UErrorCode + -> IO () + +foreign import ccall unsafe "hs_text_icu.h &__hs_ubrk_close" ubrk_close + :: FunPtr (Ptr UBreakIterator -> IO ()) + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_first" ubrk_first + :: Ptr UBreakIterator -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_last" ubrk_last + :: Ptr UBreakIterator -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_next" ubrk_next + :: Ptr UBreakIterator -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_previous" ubrk_previous + :: Ptr UBreakIterator -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_getRuleStatus" ubrk_getRuleStatus + :: Ptr UBreakIterator -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ubrk_getRuleStatusVec" ubrk_getRuleStatusVec + :: Ptr UBreakIterator -> Ptr Int32 -> Int32 -> Ptr UErrorCode -> IO Int32 diff --git a/Data/Text/ICU/Collate.hsc b/Data/Text/ICU/Collate.hsc new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Collate.hsc @@ -0,0 +1,321 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-} +-- | +-- Module : Data.Text.ICU.Collate +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- String collation functions for Unicode, implemented as bindings to +-- the International Components for Unicode (ICU) libraries. + +module Data.Text.ICU.Collate + ( + -- * Unicode collation API + -- $api + -- * Types + MCollator + , Attribute(..) + , AlternateHandling(..) + , CaseFirst(..) + , Strength(..) + -- * Functions + , open + , collate + , collateIter + -- ** Utility functions + , equals + , getAttribute + , setAttribute + , sortKey + , freeze + ) where + +#include + +import Data.ByteString (empty) +import Data.ByteString.Internal (ByteString(..), create, mallocByteString, + memcpy) +import Data.Int (Int32) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Foreign (useAsPtr) +import Data.Text.ICU.Collate.Internal (Collator(..), MCollator, UCollator, + equals, withCollator, wrap) +import Data.Text.ICU.Error.Internal (UErrorCode, handleError) +import Data.Text.ICU.Internal + (LocaleName, UChar, CharIterator, UCharIterator, + asOrdering, withCharIterator, withLocaleName) +import Data.Typeable (Typeable) +import Data.Word (Word8) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, nullPtr) + +-- $api +-- + +-- | Control the handling of variable weight elements. +data AlternateHandling = NonIgnorable + -- ^ Treat all codepoints with non-ignorable primary + -- weights in the same way. + | Shifted + -- ^ Cause codepoints with primary weights that are + -- equal to or below the variable top value to be + -- ignored on primary level and moved to the + -- quaternary level. + deriving (Eq, Bounded, Enum, Show, Typeable) + +-- | Control the ordering of upper and lower case letters. +data CaseFirst = UpperFirst -- ^ Force upper case letters to sort before + -- lower case. + | LowerFirst -- ^ Force lower case letters to sort before + -- upper case. + deriving (Eq, Bounded, Enum, Show, Typeable) + +-- | The strength attribute. The usual strength for most locales (except +-- Japanese) is tertiary. Quaternary strength is useful when combined with +-- shifted setting for alternate handling attribute and for JIS x 4061 +-- collation, when it is used to distinguish between Katakana and Hiragana +-- (this is achieved by setting 'HiraganaQuaternaryMode' mode to +-- 'True'). Otherwise, quaternary level is affected only by the number of +-- non ignorable code points in the string. Identical strength is rarely +-- useful, as it amounts to codepoints of the 'NFD' form of the string. +data Strength = Primary + | Secondary + | Tertiary + | Quaternary + | Identical + deriving (Eq, Bounded, Enum, Show, Typeable) + +data Attribute = French Bool + -- ^ Direction of secondary weights, used in French. 'True', + -- results in secondary weights being considered backwards, + -- while 'False' treats secondary weights in the order in + -- which they appear. + | AlternateHandling AlternateHandling + -- ^ For handling variable elements. 'NonIgnorable' is + -- default. + | CaseFirst (Maybe CaseFirst) + -- ^ Control the ordering of upper and lower case letters. + -- 'Nothing' (the default) orders upper and lower case + -- letters in accordance to their tertiary weights. + | CaseLevel Bool + -- ^ Controls whether an extra case level (positioned + -- before the third level) is generated or not. When + -- 'False' (default), case level is not generated; when + -- 'True', the case level is generated. Contents of the + -- case level are affected by the value of the 'CaseFirst' + -- attribute. A simple way to ignore accent differences in + -- a string is to set the strength to 'Primary' and enable + -- case level. + | NormalizationMode Bool + -- ^ Controls whether the normalization check and necessary + -- normalizations are performed. When 'False' (default) no + -- normalization check is performed. The correctness of the + -- result is guaranteed only if the input data is in + -- so-called 'FCD' form (see users manual for more info). + -- When 'True', an incremental check is performed to see + -- whether the input data is in 'FCD' form. If the data is + -- not in 'FCD' form, incremental 'NFD' normalization is + -- performed. + | Strength Strength + | HiraganaQuaternaryMode Bool + -- ^ When turned on, this attribute positions Hiragana + -- before all non-ignorables on quaternary level. This is a + -- sneaky way to produce JIS sort order. + | Numeric Bool + -- ^ When enabled, this attribute generates a collation key + -- for the numeric value of substrings of digits. This is + -- a way to get '100' to sort /after/ '2'. + deriving (Eq, Show, Typeable) + +type UColAttribute = CInt +type UColAttributeValue = CInt + +toUAttribute :: Attribute -> (UColAttribute, UColAttributeValue) +toUAttribute (French v) + = ((#const UCOL_FRENCH_COLLATION), toOO v) +toUAttribute (AlternateHandling v) + = ((#const UCOL_ALTERNATE_HANDLING), toAH v) +toUAttribute (CaseFirst v) + = ((#const UCOL_CASE_FIRST), toCF v) +toUAttribute (CaseLevel v) + = ((#const UCOL_CASE_LEVEL), toOO v) +toUAttribute (NormalizationMode v) + = ((#const UCOL_NORMALIZATION_MODE), toOO v) +toUAttribute (Strength v) + = ((#const UCOL_STRENGTH), toS v) +toUAttribute (HiraganaQuaternaryMode v) + = ((#const UCOL_HIRAGANA_QUATERNARY_MODE), toOO v) +toUAttribute (Numeric v) + = ((#const UCOL_NUMERIC_COLLATION), toOO v) + +toOO :: Bool -> UColAttributeValue +toOO False = #const UCOL_OFF +toOO True = #const UCOL_ON + +toAH :: AlternateHandling -> UColAttributeValue +toAH NonIgnorable = #const UCOL_NON_IGNORABLE +toAH Shifted = #const UCOL_SHIFTED + +toCF :: Maybe CaseFirst -> UColAttributeValue +toCF Nothing = #const UCOL_OFF +toCF (Just UpperFirst) = #const UCOL_UPPER_FIRST +toCF (Just LowerFirst) = #const UCOL_LOWER_FIRST + +toS :: Strength -> UColAttributeValue +toS Primary = #const UCOL_PRIMARY +toS Secondary = #const UCOL_SECONDARY +toS Tertiary = #const UCOL_TERTIARY +toS Quaternary = #const UCOL_QUATERNARY +toS Identical = #const UCOL_IDENTICAL + +fromOO :: UColAttributeValue -> Bool +fromOO (#const UCOL_OFF) = False +fromOO (#const UCOL_ON) = True +fromOO bad = valueError "fromOO" bad + +fromAH :: UColAttributeValue -> AlternateHandling +fromAH (#const UCOL_NON_IGNORABLE) = NonIgnorable +fromAH (#const UCOL_SHIFTED) = Shifted +fromAH bad = valueError "fromAH" bad + +fromCF :: UColAttributeValue -> Maybe CaseFirst +fromCF (#const UCOL_OFF) = Nothing +fromCF (#const UCOL_UPPER_FIRST) = Just UpperFirst +fromCF (#const UCOL_LOWER_FIRST) = Just LowerFirst +fromCF bad = valueError "fromCF" bad + +fromS :: UColAttributeValue -> Strength +fromS (#const UCOL_PRIMARY) = Primary +fromS (#const UCOL_SECONDARY) = Secondary +fromS (#const UCOL_TERTIARY) = Tertiary +fromS (#const UCOL_QUATERNARY) = Quaternary +fromS (#const UCOL_IDENTICAL) = Identical +fromS bad = valueError "fromS" bad + +fromUAttribute :: UColAttribute -> UColAttributeValue -> Attribute +fromUAttribute key val = + case key of + (#const UCOL_FRENCH_COLLATION) -> French (fromOO val) + (#const UCOL_ALTERNATE_HANDLING) -> AlternateHandling (fromAH val) + (#const UCOL_CASE_FIRST) -> CaseFirst (fromCF val) + (#const UCOL_CASE_LEVEL) -> CaseLevel (fromOO val) + (#const UCOL_NORMALIZATION_MODE) -> NormalizationMode (fromOO val) + (#const UCOL_STRENGTH) -> Strength (fromS val) + (#const UCOL_HIRAGANA_QUATERNARY_MODE) -> HiraganaQuaternaryMode (fromOO val) + (#const UCOL_NUMERIC_COLLATION) -> Numeric (fromOO val) + _ -> valueError "fromUAttribute" key + +valueError :: Show a => String -> a -> z +valueError func bad = error ("Data.Text.ICU.Collate.IO." ++ func ++ + ": invalid value " ++ show bad) + +type UCollationResult = CInt + +-- | Open a 'Collator' for comparing strings. +open :: LocaleName + -- ^ The locale containing the required collation rules. + -> IO MCollator +open loc = wrap =<< withLocaleName loc (handleError . ucol_open) + +-- | Set the value of an 'MCollator' attribute. +setAttribute :: MCollator -> Attribute -> IO () +setAttribute c a = + withCollator c $ \cptr -> + handleError $ uncurry (ucol_setAttribute cptr) (toUAttribute a) + +-- | Get the value of an 'MCollator' attribute. +-- +-- It is safe to provide a dummy argument to an 'Attribute' constructor when +-- using this function, so the following will work: +-- +-- > getAttribute mcol (NormalizationMode undefined) +getAttribute :: MCollator -> Attribute -> IO Attribute +getAttribute c a = do + let name = fst (toUAttribute a) + val <- withCollator c $ \cptr -> handleError $ ucol_getAttribute cptr name + return $! fromUAttribute name val + +-- | Compare two strings. +collate :: MCollator -> Text -> Text -> IO Ordering +collate c a b = + withCollator c $ \cptr -> + useAsPtr a $ \aptr alen -> + useAsPtr b $ \bptr blen -> + fmap asOrdering . handleError $ + ucol_strcoll cptr aptr (fromIntegral alen) bptr (fromIntegral blen) + +-- | Compare two 'CharIterator's. +-- +-- If either iterator was constructed from a 'ByteString', it does not need +-- to be copied or converted internally, so this function can be quite +-- cheap. +collateIter :: MCollator -> CharIterator -> CharIterator -> IO Ordering +collateIter c a b = + fmap asOrdering . withCollator c $ \cptr -> + withCharIterator a $ \ai -> + withCharIterator b $ handleError . ucol_strcollIter cptr ai + +-- | Create a key for sorting the 'Text' using the given 'Collator'. +-- The result of comparing two 'ByteString's that have been +-- transformed with 'sortKey' will be the same as the result of +-- 'collate' on the two untransformed 'Text's. +sortKey :: MCollator -> Text -> IO ByteString +sortKey c t + | T.null t = return empty + | otherwise = do + withCollator c $ \cptr -> + useAsPtr t $ \tptr tlen -> do + let len = fromIntegral tlen + loop n = do + fp <- mallocByteString (fromIntegral n) + i <- withForeignPtr fp $ \p -> ucol_getSortKey cptr tptr len p n + let j = fromIntegral i + case undefined of + _ | i == 0 -> error "Data.Text.ICU.Collate.IO.sortKey: internal error" + | i > n -> loop i + | i <= n `div` 2 -> create j $ \p -> withForeignPtr fp $ \op -> + memcpy p op (fromIntegral i) + | otherwise -> return $! PS fp 0 j + loop (min (len * 4) 8) + +-- | Make a safe copy of a mutable 'MCollator' for use in pure code. +-- Subsequent changes to the 'MCollator' will not affect the state of +-- the returned 'Collator'. +freeze :: MCollator -> IO Collator +freeze c = do + p <- withCollator c $ \cptr -> + with (#const U_COL_SAFECLONE_BUFFERSIZE) + (handleError . ucol_safeClone cptr nullPtr) + C `fmap` wrap p + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_open" ucol_open + :: CString -> Ptr UErrorCode -> IO (Ptr UCollator) + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_getAttribute" ucol_getAttribute + :: Ptr UCollator -> UColAttribute -> Ptr UErrorCode -> IO UColAttributeValue + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_setAttribute" ucol_setAttribute + :: Ptr UCollator -> UColAttribute -> UColAttributeValue -> Ptr UErrorCode -> IO () + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_strcoll" ucol_strcoll + :: Ptr UCollator -> Ptr UChar -> Int32 -> Ptr UChar -> Int32 + -> Ptr UErrorCode -> IO UCollationResult + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_getSortKey" ucol_getSortKey + :: Ptr UCollator -> Ptr UChar -> Int32 -> Ptr Word8 -> Int32 + -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_strcollIter" ucol_strcollIter + :: Ptr UCollator -> Ptr UCharIterator -> Ptr UCharIterator -> Ptr UErrorCode + -> IO UCollationResult + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_safeClone" ucol_safeClone + :: Ptr UCollator -> Ptr a -> Ptr Int32 -> Ptr UErrorCode + -> IO (Ptr UCollator) diff --git a/Data/Text/ICU/Collate/Internal.hs b/Data/Text/ICU/Collate/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Collate/Internal.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveDataTypeable, EmptyDataDecls, ForeignFunctionInterface #-} +-- | +-- Module : Data.Text.ICU.Collate.Internal +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Internals of the string collation infrastructure. + +module Data.Text.ICU.Collate.Internal + ( + -- * Unicode collation API + MCollator(..) + , Collator(..) + , UCollator + , equals + , withCollator + , wrap + ) where + +import Data.Text.ICU.Internal (UBool, asBool) +import Data.Typeable (Typeable) +import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, withForeignPtr) +import Foreign.Ptr (FunPtr, Ptr) +import System.IO.Unsafe (unsafePerformIO) + +-- $api +-- + +data UCollator + +-- | String collator type. +data MCollator = MCollator {-# UNPACK #-} !(ForeignPtr UCollator) + deriving (Typeable) + +-- | String collator type. 'Collator's are considered equal if they +-- will sort strings identically. +newtype Collator = C MCollator + deriving (Typeable) + +instance Eq Collator where + (C a) == (C b) = unsafePerformIO $ equals a b + +withCollator :: MCollator -> (Ptr UCollator -> IO a) -> IO a +withCollator (MCollator col) action = withForeignPtr col action +{-# INLINE withCollator #-} + +wrap :: Ptr UCollator -> IO MCollator +wrap = fmap MCollator . newForeignPtr ucol_close +{-# INLINE wrap #-} + +-- | 'MCollator's are considered equal if they will sort strings +-- identically. This means that both the current attributes and the rules +-- must be equivalent. +equals :: MCollator -> MCollator -> IO Bool +equals a b = fmap asBool . + withCollator a $ \aptr -> + withCollator b $ ucol_equals aptr + +foreign import ccall unsafe "hs_text_icu.h &__hs_ucol_close" ucol_close + :: FunPtr (Ptr UCollator -> IO ()) + +foreign import ccall unsafe "hs_text_icu.h __hs_ucol_equals" ucol_equals + :: Ptr UCollator -> Ptr UCollator -> IO UBool diff --git a/Data/Text/ICU/Collate/Pure.hs b/Data/Text/ICU/Collate/Pure.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Collate/Pure.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE DeriveDataTypeable, ForeignFunctionInterface #-} +-- | +-- Module : Data.Text.ICU.Collate.Pure +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Pure string collation functions for Unicode, implemented as +-- bindings to the International Components for Unicode (ICU) +-- libraries. +-- +-- For the impure collation API (which is richer, but less easy to +-- use), see the 'Data.Text.ICU.CollateO' module. + +module Data.Text.ICU.Collate.Pure + ( + -- * Unicode collation API + -- $api + Collator + , collator + , collate + , collateIter + , sortKey + , uca + ) where + +#include + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text.ICU.Collate.Internal (Collator(..)) +import Data.Text.ICU.Internal (CharIterator, LocaleName(..)) +import System.IO.Unsafe (unsafePerformIO) +import qualified Data.Text.ICU.Collate as IO + +-- $api +-- + +-- | Create an immutable 'Collator' for comparing strings. +-- +-- If 'Root' is passed as the locale, UCA collation rules will be +-- used. +collator :: LocaleName -> Collator +collator loc = unsafePerformIO $ C `fmap` IO.open loc + +-- | Compare two strings. +collate :: Collator -> Text -> Text -> Ordering +collate (C c) a b = unsafePerformIO $ IO.collate c a b +{-# INLINE collate #-} + +-- | Compare two 'CharIterator's. +-- +-- If either iterator was constructed from a 'ByteString', it does not +-- need to be copied or converted beforehand, so this function can be +-- quite cheap. +collateIter :: Collator -> CharIterator -> CharIterator -> Ordering +collateIter (C c) a b = unsafePerformIO $ IO.collateIter c a b +{-# INLINE collateIter #-} + +-- | Create a key for sorting the 'Text' using the given 'Collator'. +-- The result of comparing two 'ByteString's that have been +-- transformed with 'sortKey' will be the same as the result of +-- 'collate' on the two untransformed 'Text's. +sortKey :: Collator -> Text -> ByteString +sortKey (C c) = unsafePerformIO . IO.sortKey c +{-# INLINE sortKey #-} + +-- | A 'Collator' that uses the Unicode Collation Algorithm (UCA). +uca :: Collator +uca = collator Root +{-# NOINLINE uca #-} diff --git a/Data/Text/ICU/Convert.hs b/Data/Text/ICU/Convert.hs --- a/Data/Text/ICU/Convert.hs +++ b/Data/Text/ICU/Convert.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# LANGUAGE ForeignFunctionInterface #-} -- | -- Module : Data.Text.ICU.Convert --- Copyright : (c) Bryan O'Sullivan 2009 +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com @@ -11,7 +11,6 @@ -- Character set conversion functions for Unicode, implemented as -- bindings to the International Components for Unicode (ICU) -- libraries. - module Data.Text.ICU.Convert ( -- * Character set conversion @@ -47,9 +46,9 @@ import Foreign.C.Types (CInt) import Foreign.ForeignPtr (newForeignPtr) import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (FunPtr, Ptr, castPtr, nullPtr) +import Foreign.Ptr (FunPtr, Ptr, castPtr) import System.IO.Unsafe (unsafePerformIO) -import Data.Text.ICU.Internal (UBool, UChar, asBool, asOrdering) +import Data.Text.ICU.Internal (UBool, UChar, asBool, asOrdering, withName) -- | Do a fuzzy compare of two converter/alias names. The comparison -- is case-insensitive, ignores leading zeroes if they are not @@ -96,14 +95,11 @@ -- (see 'usesFallback' for details). -> IO Converter open name mf = do - c <- fmap Converter . newForeignPtr ucnv_close =<< named (handleError . ucnv_open) + c <- fmap Converter . newForeignPtr ucnv_close =<< withName name (handleError . ucnv_open) case mf of Just f -> withConverter c $ \p -> ucnv_setFallback p . fromIntegral . fromEnum $ f _ -> return () return c - where named act - | null name = act nullPtr - | otherwise = withCString name act -- | Convert the Unicode string into a codepage string using the given -- converter. diff --git a/Data/Text/ICU/Error.hsc b/Data/Text/ICU/Error.hsc --- a/Data/Text/ICU/Error.hsc +++ b/Data/Text/ICU/Error.hsc @@ -1,7 +1,20 @@ +-- | +-- Module : Data.Text.ICU.Error +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Errors thrown by bindings to the International Components for +-- Unicode (ICU) libraries. +-- +-- Most ICU functions can throw an 'ICUError' value as an exception. module Data.Text.ICU.Error ( -- * Types - ErrorCode, + ICUError, -- * Functions isSuccess, @@ -153,7 +166,7 @@ import Data.Text.ICU.Error.Internal -#{enum ErrorCode, ErrorCode, +#{enum ICUError, ICUError, u_USING_FALLBACK_WARNING = U_USING_FALLBACK_WARNING, u_USING_DEFAULT_WARNING = U_USING_DEFAULT_WARNING, u_SAFECLONE_ALLOCATED_WARNING = U_SAFECLONE_ALLOCATED_WARNING, diff --git a/Data/Text/ICU/Error/Internal.hs b/Data/Text/ICU/Error/Internal.hs --- a/Data/Text/ICU/Error/Internal.hs +++ b/Data/Text/ICU/Error/Internal.hs @@ -3,7 +3,7 @@ module Data.Text.ICU.Error.Internal ( -- * Types - ErrorCode(..) + ICUError(..) -- ** Low-level types , UErrorCode -- * Functions @@ -17,32 +17,34 @@ import Control.Exception (Exception, throw) import Foreign.Ptr (Ptr) -import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Utils (with) import Data.Typeable (Typeable) import Foreign.C.String (CString, peekCString) import Foreign.C.Types (CInt) -import Foreign.Storable (peek, poke) +import Foreign.Storable (peek) import System.IO.Unsafe (unsafePerformIO) type UErrorCode = CInt --- | ICU error code. -newtype ErrorCode = ErrorCode { +-- | ICU error type. This is an instance of the 'Exception' type +-- class. A value of this type may be thrown as an exception by most +-- ICU functions. +newtype ICUError = ICUError { fromErrorCode :: UErrorCode } deriving (Eq, Typeable) -instance Show ErrorCode where - show code = "ErrorCode " ++ errorName code +instance Show ICUError where + show code = "ICUError " ++ errorName code -instance Exception ErrorCode +instance Exception ICUError -- | Indicate whether the given error code is a success. -isSuccess :: ErrorCode -> Bool +isSuccess :: ICUError -> Bool {-# INLINE isSuccess #-} isSuccess = (<= 0) . fromErrorCode -- | Indicate whether the given error code is a failure. -isFailure :: ErrorCode -> Bool +isFailure :: ICUError -> Bool {-# INLINE isFailure #-} isFailure = (> 0) . fromErrorCode @@ -50,29 +52,27 @@ throwOnError :: UErrorCode -> IO () {-# INLINE throwOnError #-} throwOnError code = do - let err = (ErrorCode code) + let err = (ICUError code) if isFailure err then throw err else return () -withError :: (Ptr UErrorCode -> IO a) -> IO (ErrorCode, a) +withError :: (Ptr UErrorCode -> IO a) -> IO (ICUError, a) {-# INLINE withError #-} -withError action = alloca $ \errPtr -> do - poke errPtr 0 +withError action = with 0 $ \errPtr -> do ret <- action errPtr err <- peek errPtr - return (ErrorCode err, ret) + return (ICUError err, ret) handleError :: (Ptr UErrorCode -> IO a) -> IO a {-# INLINE handleError #-} -handleError action = alloca $ \errPtr -> do - poke errPtr 0 +handleError action = with 0 $ \errPtr -> do ret <- action errPtr throwOnError =<< peek errPtr return ret -- | Return a string representing the name of the given error code. -errorName :: ErrorCode -> String +errorName :: ICUError -> String errorName code = unsafePerformIO $ peekCString (u_errorName (fromErrorCode code)) diff --git a/Data/Text/ICU/Internal.hs b/Data/Text/ICU/Internal.hs deleted file mode 100644 --- a/Data/Text/ICU/Internal.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Data.Text.ICU.Internal - ( - UBool - , UChar - , asBool - , asOrdering - ) where - -import Data.Int (Int8) -import Data.Word (Word16) - -type UBool = Int8 -type UChar = Word16 - -asBool :: Integral a => a -> Bool -{-# INLINE asBool #-} -asBool = (/=0) - -asOrdering :: Integral a => a -> Ordering -{-# INLINE asOrdering #-} -asOrdering i - | i < 0 = LT - | i == 0 = EQ - | otherwise = GT diff --git a/Data/Text/ICU/Internal.hsc b/Data/Text/ICU/Internal.hsc new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Internal.hsc @@ -0,0 +1,99 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} + +module Data.Text.ICU.Internal + ( + LocaleName(..) + , UBool + , UChar + , UCharIterator + , CharIterator(..) + , asBool + , asOrdering + , withCharIterator + , withLocaleName + , withName + ) where + +#include + +import Data.ByteString.Internal (ByteString(..)) +import Data.Int (Int8, Int32) +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) +import Data.Text.Foreign (useAsPtr) +import Data.Word (Word16) +import Foreign.C.String (CString, withCString) +import Foreign.C.Types (CChar) +import Foreign.Marshal.Alloc (alloca) +import Foreign.ForeignPtr (withForeignPtr) +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (Storable(..)) + +-- | A type that supports efficient iteration over Unicode characters. +-- +-- As an example of where this may be useful, a function using this +-- type may be able to iterate over a UTF-8 'ByteString' directly, +-- rather than first copying and converting it to an intermediate +-- form. This type also allows e.g. comparison between 'Text' and +-- 'ByteString', with minimal overhead. +data CharIterator = CIText !Text + | CIUTF8 !ByteString + +instance Show CharIterator where + show (CIText t) = show t + show (CIUTF8 bs) = show (decodeUtf8 bs) + +data UCharIterator + +instance Storable UCharIterator where + sizeOf _ = #{size UCharIterator} + alignment _ = alignment (undefined :: CString) + +-- | Temporarily allocate a 'UCharIterator' and use it with the +-- contents of the to-be-iterated-over string. +withCharIterator :: CharIterator -> (Ptr UCharIterator -> IO a) -> IO a +withCharIterator (CIUTF8 (PS fp _ l)) act = + alloca $ \i -> withForeignPtr fp $ \p -> + uiter_setUTF8 i (castPtr p) (fromIntegral l) >> act i +withCharIterator (CIText t) act = + alloca $ \i -> useAsPtr t $ \p l -> + uiter_setString i p (fromIntegral l) >> act i + +type UBool = Int8 +type UChar = Word16 + +asBool :: Integral a => a -> Bool +{-# INLINE asBool #-} +asBool = (/=0) + +asOrdering :: Integral a => a -> Ordering +{-# INLINE asOrdering #-} +asOrdering i + | i < 0 = LT + | i == 0 = EQ + | otherwise = GT + +withName :: String -> (CString -> IO a) -> IO a +withName name act + | null name = act nullPtr + | otherwise = withCString name act + +-- | The name of a locale. +data LocaleName = Root + -- ^ The root locale. For a description of resource bundles + -- and the root resource, see + -- . + | Locale String -- ^ A specific locale. + | Current -- ^ The program's current locale. + deriving (Eq, Ord, Read, Show) + +withLocaleName :: LocaleName -> (CString -> IO a) -> IO a +withLocaleName Current act = act nullPtr +withLocaleName Root act = withCString "" act +withLocaleName (Locale n) act = withCString n act + +foreign import ccall unsafe "hs_text_icu.h __hs_uiter_setString" uiter_setString + :: Ptr UCharIterator -> Ptr UChar -> Int32 -> IO () + +foreign import ccall unsafe "hs_text_icu.h __hs_uiter_setUTF8" uiter_setUTF8 + :: Ptr UCharIterator -> Ptr CChar -> Int32 -> IO () diff --git a/Data/Text/ICU/Iterator.hs b/Data/Text/ICU/Iterator.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Iterator.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Text.ICU.Iterator +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Iteration functions for Unicode, implemented as bindings to the +-- International Components for Unicode (ICU) libraries. +-- +-- Unlike the C and C++ @UCharIterator@ type, the Haskell +-- 'CharIterator' type is immutable, and can safely be used in pure +-- code. +-- +-- Functions using these iterators may be more efficient than their +-- counterparts. For instance, the 'CharIterator' type allows a UTF-8 +-- 'ByteString' to be compared against a 'Text', without first +-- converting the 'ByteString': +-- +-- > fromUtf8 bs == fromText t +module Data.Text.ICU.Iterator + ( + -- * Types and constructors + CharIterator + , fromString + , fromText + , fromUtf8 + ) where + +import Data.ByteString (ByteString) +import Data.Int (Int32) +import Data.Text (Text, pack) +import Data.Text.ICU.Internal (CharIterator(..), UCharIterator, asOrdering, + withCharIterator) +import Foreign.Ptr (Ptr) +import System.IO.Unsafe (unsafePerformIO) + +instance Eq CharIterator where + a == b = compareIter a b == EQ + +instance Ord CharIterator where + compare = compareIter + +-- | Compare two 'CharIterator's. +compareIter :: CharIterator -> CharIterator -> Ordering +compareIter a b = unsafePerformIO . fmap asOrdering . + withCharIterator a $ withCharIterator b . u_strCompareIter + +-- | Construct a 'CharIterator' from a Unicode string. +fromString :: String -> CharIterator +fromString = CIText . pack +{-# INLINE fromString #-} + +-- | Construct a 'CharIterator' from a Unicode string. +fromText :: Text -> CharIterator +fromText = CIText +{-# INLINE fromText #-} + +-- | Construct a 'CharIterator' from a Unicode string encoded as a +-- UTF-8 'ByteString'. +fromUtf8 :: ByteString -> CharIterator +fromUtf8 = CIUTF8 +{-# INLINE fromUtf8 #-} + +foreign import ccall unsafe "hs_text_icu.h __hs_u_strCompareIter" u_strCompareIter + :: Ptr UCharIterator -> Ptr UCharIterator -> IO Int32 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 @@ -1,8 +1,7 @@ -{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP, DeriveDataTypeable, ForeignFunctionInterface #-} -- | -- Module : Data.Text.ICU.Normalize --- Copyright : (c) Bryan O'Sullivan 2009 +-- Copyright : (c) 2009, 2010 Bryan O'Sullivan -- -- License : BSD-style -- Maintainer : bos@serpentine.com @@ -21,7 +20,6 @@ -- * Normalization functions , normalize -- * Normalization checks - , NormalizationCheckResult(..) , quickCheck , isNormalized -- * Normalization-sensitive comparison @@ -56,10 +54,10 @@ -- $api -- --- 'normalize' transforms Unicode text into an equivalent composed or --- decomposed form, allowing for easier sorting and searching of text. --- 'normalize' supports the standard normalization forms described in --- , +-- The 'normalize' function transforms Unicode text into an equivalent +-- composed or decomposed form, allowing for easier sorting and +-- searching of text. 'normalize' supports the standard normalization +-- forms described in , -- Unicode Standard Annex #15: Unicode Normalization Forms. -- -- Characters with accents or other adornments can be encoded in @@ -163,12 +161,9 @@ -- | Options to 'compare'. data CompareOption = InputIsFCD -- ^ The caller knows that both strings fulfill the - -- 'FCD' conditions. If not set, 'compare' will + -- 'FCD' conditions. If /not/ set, 'compare' will -- 'quickCheck' for 'FCD' and normalize if -- necessary. - | CompareCodePointOrder - -- ^ Choose code point order instead of code unit - -- order. | CompareIgnoreCase -- ^ Compare strings case-insensitively using case -- folding, instead of case-sensitively. If set, @@ -182,12 +177,11 @@ fromCompareOption :: CompareOption -> UCompareOption fromCompareOption InputIsFCD = #const UNORM_INPUT_IS_FCD -fromCompareOption CompareCodePointOrder = #const U_COMPARE_CODE_POINT_ORDER fromCompareOption CompareIgnoreCase = #const U_COMPARE_IGNORE_CASE fromCompareOption FoldCaseExcludeSpecialI = #const U_FOLD_CASE_EXCLUDE_SPECIAL_I reduceCompareOptions :: [CompareOption] -> UCompareOption -reduceCompareOptions = foldl' orO (#const U_FOLD_CASE_DEFAULT) +reduceCompareOptions = foldl' orO (#const U_COMPARE_CODE_POINT_ORDER) where a `orO` b = a .|. fromCompareOption b type UNormalizationMode = CInt @@ -212,18 +206,10 @@ type UNormalizationCheckResult = CInt --- | Result of a fast normalization check using 'quickCheck'. -data NormalizationCheckResult - = No -- ^ Text is not normalized. - | Perhaps -- ^ It cannot be determined whether text is in normalized - -- form without further thorough checks. - | Yes -- ^ Text is in normalized form. - deriving (Eq, Show, Enum, Typeable) - -toNCR :: UNormalizationCheckResult -> NormalizationCheckResult -toNCR (#const UNORM_NO) = No -toNCR (#const UNORM_MAYBE) = Perhaps -toNCR (#const UNORM_YES) = Yes +toNCR :: UNormalizationCheckResult -> Maybe Bool +toNCR (#const UNORM_NO) = Just False +toNCR (#const UNORM_MAYBE) = Nothing +toNCR (#const UNORM_YES) = Just True toNCR _ = error "toNormalizationCheckResult" -- | Normalize a string according the specified normalization mode. @@ -246,12 +232,16 @@ -- | Perform an efficient check on a string, to quickly determine if --- the string is in a particular normalization format. +-- the string is in a particular normalization form. -- --- A 'Perhaps' result indicates that a more thorough check is --- required, e.g. with 'isNormalized'. The user may have to put the --- string in its normalized form and compare the results. -quickCheck :: NormalizationMode -> Text -> NormalizationCheckResult +-- A 'Nothing' result indicates that a certain answer could not be +-- determined quickly, and a more thorough check is required, +-- e.g. with 'isNormalized'. The user may have to convert the string +-- to its normalized form and compare the results. +-- +-- A result of 'Just' 'True' or 'Just' 'False' indicates that the +-- string definitely is, or is not, in the given normalization form. +quickCheck :: NormalizationMode -> Text -> Maybe Bool quickCheck mode t = unsafePerformIO . useAsPtr t $ \ptr len -> fmap toNCR . handleError $ unorm_quickCheck ptr (fromIntegral len) @@ -281,9 +271,9 @@ -- performance significantly. -- -- Bulk normalization is only necessary if the strings do not fulfill --- the FCD conditions. Only in this case, and only if the strings are --- relatively long, is memory allocated temporarily. For FCD strings --- and short non-FCD strings there is no memory allocation. +-- the 'FCD' conditions. Only in this case, and only if the strings +-- are relatively long, is memory allocated temporarily. For 'FCD' +-- strings and short non-'FCD' strings there is no memory allocation. compare :: [CompareOption] -> Text -> Text -> Ordering compare opts a b = unsafePerformIO . useAsPtr a $ \aptr alen -> diff --git a/Data/Text/ICU/Text.hs b/Data/Text/ICU/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Text.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- | +-- Module : Data.Text.ICU.Text +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Functions for manipulating Unicode text, implemented as bindings to +-- the International Components for Unicode (ICU) libraries. +module Data.Text.ICU.Text + ( + -- * Case conversion + -- $case + toCaseFold + , toLower + , toUpper + ) where + +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.Internal (LocaleName, UChar, withLocaleName) +import Data.Word (Word32) +import Foreign.C.String (CString) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (Ptr) +import System.IO.Unsafe (unsafePerformIO) + +-- $case +-- +-- In some languages, case conversion is a locale- and +-- context-dependent operation. The case conversion functions in this +-- module are locale and context sensitive. + +-- | Case-fold the characters in a string. +-- +-- Case folding is locale independent and not context sensitive, but +-- there is an option for treating the letter I specially for Turkic +-- languages. The result may be longer or shorter than the original. +toCaseFold :: Bool -- ^ Whether to include or exclude mappings for + -- dotted and dotless I and i that are marked with + -- 'I' in @CaseFolding.txt@. + -> Text -> Text +toCaseFold excludeI s = unsafePerformIO . + useAsPtr s $ \sptr slen -> do + let opts = fromIntegral . fromEnum $ excludeI + go len = allocaArray len $ \dptr -> do + n <- fmap fromIntegral . handleError $ + u_strFoldCase dptr (fromIntegral len) sptr + (fromIntegral slen) opts + if n > len + then go n + else fromPtr dptr n + go slen + +type CaseMapper = Ptr UChar -> Int32 -> Ptr UChar -> Int32 -> CString + -> Ptr UErrorCode -> IO Int32 + +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 n + go slen + +-- | Lowercase the characters in a string. +-- +-- Casing is locale dependent and context sensitive. The result may +-- be longer or shorter than the original. +toLower :: LocaleName -> Text -> Text +toLower = caseMap u_strToLower + +-- | Uppercase the characters in a string. +-- +-- Casing is locale dependent and context sensitive. The result may +-- be longer or shorter than the original. +toUpper :: LocaleName -> Text -> Text +toUpper = caseMap u_strToUpper + +foreign import ccall unsafe "hs_text_icu.h __hs_u_strFoldCase" u_strFoldCase + :: Ptr UChar -> Int32 -> Ptr UChar -> Int32 -> Word32 -> Ptr UErrorCode + -> IO Int32 + +foreign import ccall unsafe "hs_text_icu.h __hs_u_strToLower" u_strToLower + :: CaseMapper + +foreign import ccall unsafe "hs_text_icu.h __hs_u_strToUpper" u_strToUpper + :: CaseMapper diff --git a/Data/Text/ICU/Types.hs b/Data/Text/ICU/Types.hs new file mode 100644 --- /dev/null +++ b/Data/Text/ICU/Types.hs @@ -0,0 +1,18 @@ +-- | +-- Module : Data.Text.ICU.Types +-- Copyright : (c) 2010 Bryan O'Sullivan +-- +-- License : BSD-style +-- Maintainer : bos@serpentine.com +-- Stability : experimental +-- Portability : GHC +-- +-- Types for use when manipulating Unicode text, using the bindings to +-- the International Components for Unicode (ICU) libraries. +module Data.Text.ICU.Types + ( + -- * Widely used types + LocaleName(..) + ) where + +import Data.Text.ICU.Internal (LocaleName(..)) diff --git a/cbits/text_icu.c b/cbits/text_icu.c --- a/cbits/text_icu.c +++ b/cbits/text_icu.c @@ -1,5 +1,112 @@ #include "hs_text_icu.h" +UBreakIterator* __hs_ubrk_open(UBreakIteratorType type, const char *locale, + const UChar *text, int32_t textLength, + UErrorCode *status) +{ + return ubrk_open(type, locale, text, textLength, status); +} + +void __hs_ubrk_close(UBreakIterator *bi) +{ + ubrk_close(bi); +} + +void __hs_ubrk_setText(UBreakIterator* bi, const UChar *text, + int32_t textLength, UErrorCode *status) +{ + ubrk_setText(bi, text, textLength, status); +} + +int32_t __hs_ubrk_first(UBreakIterator *bi) +{ + return ubrk_first(bi); +} + +int32_t __hs_ubrk_last(UBreakIterator *bi) +{ + return ubrk_last(bi); +} + +int32_t __hs_ubrk_next(UBreakIterator *bi) +{ + return ubrk_next(bi); +} + +int32_t __hs_ubrk_previous(UBreakIterator *bi) +{ + return ubrk_previous(bi); +} + +int32_t __hs_ubrk_getRuleStatus(UBreakIterator *bi) +{ + return ubrk_getRuleStatus(bi); +} + +int32_t __hs_ubrk_getRuleStatusVec(UBreakIterator *bi, int32_t *fillInVec, + int32_t capacity, UErrorCode *status) +{ + return ubrk_getRuleStatusVec(bi, fillInVec, capacity, status); +} + +UCollator* __hs_ucol_open(const char *loc, UErrorCode *status) +{ + return ucol_open(loc, status); +} + +void __hs_ucol_close(UCollator *coll) +{ + ucol_close(coll); +} + +void __hs_ucol_setAttribute(UCollator *coll, UColAttribute attr, + UColAttributeValue value, UErrorCode *status) +{ + ucol_setAttribute(coll, attr, value, status); +} + +UColAttributeValue __hs_ucol_getAttribute(const UCollator *coll, + UColAttribute attr, + UErrorCode *status) +{ + return ucol_getAttribute(coll, attr, status); +} + +UCollationResult __hs_ucol_strcoll(const UCollator *coll, + const UChar *source, int32_t sourceLength, + const UChar *target, int32_t targetLength) +{ + return ucol_strcoll(coll, source, sourceLength, target, targetLength); +} + +UCollationResult __hs_ucol_strcollIter(const UCollator *coll, + UCharIterator *sIter, + UCharIterator *tIter, + UErrorCode *status) +{ + return ucol_strcollIter(coll, sIter, tIter, status); +} + +UCollator* __hs_ucol_safeClone(const UCollator *coll, + void *stackBuffer, + int32_t *pBufferSize, + UErrorCode *status) +{ + return ucol_safeClone(coll, stackBuffer, pBufferSize, status); +} + +int32_t __hs_ucol_getSortKey(const UCollator *coll, + const UChar *source, int32_t sourceLength, + uint8_t *result, int32_t resultLength) +{ + return ucol_getSortKey(coll, source, sourceLength, result, resultLength); +} + +UBool __hs_ucol_equals(const UCollator *source, const UCollator *target) +{ + return ucol_equals(source, target); +} + int __get_max_bytes_for_string(UConverter *cnv, int src_length) { return UCNV_GET_MAX_BYTES_FOR_STRING(src_length, ucnv_getMaxCharSize(cnv)); @@ -100,6 +207,16 @@ return ucnv_isAmbiguous(cnv); } +void __hs_uiter_setString(UCharIterator *iter, const UChar *s, int32_t length) +{ + uiter_setString(iter, s, length); +} + +void __hs_uiter_setUTF8(UCharIterator *iter, const char *s, int32_t length) +{ + uiter_setUTF8(iter, s, length); +} + int32_t __hs_unorm_compare(const UChar *s1, int32_t length1, const UChar *s2, int32_t length2, uint32_t options, @@ -131,3 +248,32 @@ return unorm_normalize(source, sourceLength, mode, options, result, resultLength, status); } + +int32_t __hs_u_strToUpper(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + const char *locale, UErrorCode *pErrorCode) +{ + return u_strToUpper(dest, destCapacity, src, srcLength, locale, pErrorCode); +} + +int32_t __hs_u_strToLower(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + const char *locale, UErrorCode *pErrorCode) +{ + return u_strToLower(dest, destCapacity, src, srcLength, locale, pErrorCode); +} + +int32_t __hs_u_strFoldCase(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + uint32_t options, UErrorCode *pErrorCode) +{ + return u_strFoldCase(dest, destCapacity, src, srcLength, options, + pErrorCode); +} + +int32_t __hs_u_strCompareIter(UCharIterator *iter1, UCharIterator *iter2) +{ + return u_strCompareIter(iter1, iter2, TRUE); +} + + diff --git a/include/hs_text_icu.h b/include/hs_text_icu.h --- a/include/hs_text_icu.h +++ b/include/hs_text_icu.h @@ -3,11 +3,57 @@ #endif #include "unicode/utypes.h" + +#include "unicode/ubrk.h" +#include "unicode/ucol.h" #include "unicode/ucnv.h" +#include "unicode/uiter.h" #include "unicode/unorm.h" +#include "unicode/ustring.h" #include +/* ubrk.h */ + +UBreakIterator* __hs_ubrk_open(UBreakIteratorType type, const char *locale, + const UChar *text, int32_t textLength, + UErrorCode *status); +void __hs_ubrk_close(UBreakIterator *bi); +void __hs_ubrk_setText(UBreakIterator* bi, const UChar *text, + int32_t textLength, UErrorCode *status); +int32_t __hs_ubrk_first(UBreakIterator *bi); +int32_t __hs_ubrk_last(UBreakIterator *bi); +int32_t __hs_ubrk_next(UBreakIterator *bi); +int32_t __hs_ubrk_previous(UBreakIterator *bi); +int32_t __hs_ubrk_getRuleStatus(UBreakIterator *bi); +int32_t __hs_ubrk_getRuleStatusVec(UBreakIterator *bi, int32_t *fillInVec, + int32_t capacity, UErrorCode *status); + +/* ucol.h */ + +UCollator* __hs_ucol_open(const char *loc, UErrorCode *status); +void __hs_ucol_close(UCollator *coll); +void __hs_ucol_setAttribute(UCollator *coll, UColAttribute attr, + UColAttributeValue value, UErrorCode *status); +UColAttributeValue __hs_ucol_getAttribute(const UCollator *coll, + UColAttribute attr, + UErrorCode *status); +UCollationResult __hs_ucol_strcoll(const UCollator *coll, + const UChar *source, int32_t sourceLength, + const UChar *target, int32_t targetLength); +UCollationResult __hs_ucol_strcollIter(const UCollator *coll, + UCharIterator *sIter, + UCharIterator *tIter, + UErrorCode *status); +UCollator* __hs_ucol_safeClone(const UCollator *coll, + void *stackBuffer, + int32_t *pBufferSize, + UErrorCode *status); +int32_t __hs_ucol_getSortKey(const UCollator *coll, + const UChar *source, int32_t sourceLength, + uint8_t *result, int32_t resultLength); +UBool __hs_ucol_equals(const UCollator *source, const UCollator *target); + /* ucnv.h */ int __get_max_bytes_for_string(UConverter *cnv, int src_length); @@ -35,6 +81,11 @@ void __hs_ucnv_setFallback(UConverter *cnv, UBool usesFallback); UBool __hs_ucnv_isAmbiguous(const UConverter *cnv); +/* uiter.h */ + +void __hs_uiter_setString(UCharIterator *iter, const UChar *s, int32_t length); +void __hs_uiter_setUTF8(UCharIterator *iter, const char *s, int32_t length); + /* unorm.h */ int32_t __hs_unorm_compare(const UChar *s1, int32_t length1, @@ -52,3 +103,16 @@ UNormalizationMode mode, int32_t options, UChar *result, int32_t resultLength, UErrorCode *status); + +/* ustring.h */ + +int32_t __hs_u_strFoldCase(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + uint32_t options, UErrorCode *pErrorCode); +int32_t __hs_u_strToUpper(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + const char *locale, UErrorCode *pErrorCode); +int32_t __hs_u_strToLower(UChar *dest, int32_t destCapacity, + const UChar *src, int32_t srcLength, + const char *locale, UErrorCode *pErrorCode); +int32_t __hs_u_strCompareIter(UCharIterator *iter1, UCharIterator *iter2); diff --git a/text-icu.cabal b/text-icu.cabal --- a/text-icu.cabal +++ b/text-icu.cabal @@ -1,5 +1,5 @@ name: text-icu -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Bindings to the ICU library description: Haskell bindings to the International Components for Unicode (ICU) libraries. These libraries provide @@ -11,7 +11,7 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.2 +cabal-version: >= 1.6 extra-source-files: README include/hs_text_icu.h @@ -21,13 +21,21 @@ build-depends: base >= 4 exposed-modules: + Data.Text.ICU + Data.Text.ICU.Collate Data.Text.ICU.Convert Data.Text.ICU.Error Data.Text.ICU.Normalize + Data.Text.ICU.Types other-modules: + Data.Text.ICU.Break + Data.Text.ICU.Collate.Internal + Data.Text.ICU.Collate.Pure Data.Text.ICU.Convert.Internal Data.Text.ICU.Error.Internal Data.Text.ICU.Internal + Data.Text.ICU.Iterator + Data.Text.ICU.Text c-sources: cbits/text_icu.c include-dirs: include extra-libraries: icuuc @@ -39,3 +47,7 @@ ghc-options: -Wall if impl(ghc >= 6.8) ghc-options: -fwarn-tabs + +source-repository head + type: darcs + location: http://code.haskell.org/text-icu/