text-icu-translit (empty) → 0.1.0.7
raw patch · 9 files changed
+439/−0 lines, 9 filesdep +QuickCheckdep +basedep +test-frameworksetup-changed
Dependencies added: QuickCheck, base, test-framework, test-framework-quickcheck2, text, text-icu, text-icu-translit
Files
- Data/Text/ICU/Translit.hs +40/−0
- Data/Text/ICU/Translit/ICUHelper.hsc +122/−0
- Data/Text/ICU/Translit/Internal.hs +54/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/trans.c +55/−0
- include/trans.h +11/−0
- tests/Test.hs +64/−0
- text-icu-translit.cabal +61/−0
+ Data/Text/ICU/Translit.hs view
@@ -0,0 +1,40 @@+-- |+-- Module: Data.Text.ICU.Translit+-- License: BSD-style+-- Maintainer: me@lelf.lu+-- +-- This module provides the bindings to the transliteration features+-- by the ICU (International Components for Unicode) library.+-- +-- >>> IO.putStrLn $ transliterate (trans "name-any; ru") "\\N{RABBIT FACE} Nu pogodi!"+-- 🐰 Ну погоди!+-- +-- >>> IO.putStrLn $ transliterate (trans "nl-title") "gelderse ijssel"+-- Gelderse IJssel+-- +-- >>> IO.putStrLn $ transliterate (trans "ja") "Amsterdam"+-- アムステルダム+-- +-- More information about the rules is+-- <http://userguide.icu-project.org/transforms/general here>.++++module Data.Text.ICU.Translit+ (IO.Transliterator, trans, transliterate) where++import qualified Data.Text.ICU.Translit.Internal as IO+import System.IO.Unsafe+import Data.Text+++-- | Construct new transliterator by name. Will throw an error if+-- there is no such transliterator+trans :: Text -> IO.Transliterator+trans t = unsafePerformIO $ IO.transliterator t+++-- | Transliterate the text using the transliterator+transliterate :: IO.Transliterator -> Text -> Text+transliterate tr txt = unsafePerformIO $ IO.transliterate tr txt+
+ Data/Text/ICU/Translit/ICUHelper.hsc view
@@ -0,0 +1,122 @@+{-# LANGUAGE DeriveDataTypeable, MultiWayIf #-}+module Data.Text.ICU.Translit.ICUHelper+ (+ ICUError(..)+ , UChar+ , UErrorCode+ , isFailure+ , errorName+ , handleError+ , handleFilledOverflowError+ , throwOnError+ ) where+++-- Many functions in this module are straight from the+-- Data.Text.ICU.Error.Internal (text-icu).+-- +-- XXX TODO:+-- ⋆ export this and similar functionality somewhere;+-- or+-- ⋆ merge text-icu-* into text-icu?+++import Control.Exception (Exception, throwIO)+import Data.Typeable (Typeable)+import Foreign.C.Types (CInt(..))+import Foreign.C.String (CString, peekCString)+import qualified System.IO.Unsafe as IO (unsafePerformIO)+import Foreign ++type UErrorCode = CInt+type UChar = Word16++newtype ICUError = ICUError {+ fromErrorCode :: UErrorCode+ } deriving (Eq, Typeable)++instance Show ICUError where+ show code = "ICUError " ++ errorName code++instance Exception ICUError+++#include <unicode/utypes.h>+++-- | Indicate whether the given error code is a failure.+isFailure :: ICUError -> Bool+{-# INLINE isFailure #-}+isFailure = (> 0) . fromErrorCode+++-- | Throw an exception if the given code is actually an error.+throwOnError :: UErrorCode -> IO ()+{-# INLINE throwOnError #-}+throwOnError code = do+ let err = (ICUError code)+ if isFailure err+ then throwIO err+ else return ()++++handleError :: (Ptr UErrorCode -> IO a) -> IO a+{-# INLINE handleError #-}+handleError action = with 0 $ \errPtr -> do+ ret <- action errPtr+ throwOnError =<< peek errPtr+ return ret++++-- | Deal with ICU functions that report a buffer overflow error if we+-- give them an insufficiently large buffer. The difference between+-- this function and+-- 'Data.Text.ICU.Error.Internal.handleOverflowError' is that this one+-- doesn't change the contents of the provided buffer, while the+-- latter assumes buffers to be write-only.+handleFilledOverflowError :: (Storable a) =>+ Ptr a+ -- ^ Initial buffer.+ -> Int+ -- ^ Initial 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+handleFilledOverflowError text len0 fill retrieve =+ do buf0 <- mallocArray len0+ copyArray buf0 text len0+ go buf0 len0+ where+ go buf len = alloca $ \errPtr -> do+ poke errPtr 0+ len' <- fill buf (fromIntegral len) errPtr+ err <- peek errPtr+ if | err == (#const U_BUFFER_OVERFLOW_ERROR)+ -> do buf' <- reallocArray buf (fromIntegral len')+ copyArray buf' text len0+ go buf' (fromIntegral len')+ | err > 0+ -> throwIO (ICUError err)+ | otherwise+ -> retrieve buf (fromIntegral len')+++++++++-- | Return a string representing the name of the given error code.+errorName :: ICUError -> String+errorName code = IO.unsafePerformIO $+ peekCString (u_errorName (fromErrorCode code))++foreign import ccall unsafe "trans.h __hs_translit_u_errorName" u_errorName+ :: UErrorCode -> CString+
+ Data/Text/ICU/Translit/Internal.hs view
@@ -0,0 +1,54 @@+module Data.Text.ICU.Translit.Internal+ (Transliterator,+ transliterator,+ transliterate) where++import Foreign+import Data.Text+import Data.Text.Foreign+import Data.Text.ICU.Translit.ICUHelper++data UTransliterator++foreign import ccall "trans.h __hs_translit_open_trans" openTrans+ :: Ptr UChar -> Int -> Ptr UErrorCode -> IO (Ptr UTransliterator)+foreign import ccall "trans.h &__hs_translit_close_trans" closeTrans+ :: FunPtr (Ptr UTransliterator -> IO ())+foreign import ccall "trans.h __hs_translit_do_trans" doTrans+ :: Ptr UTransliterator -> Ptr UChar -> Int32 -> Int32+ -> Ptr UErrorCode -> IO Int32++++data Transliterator = Transliterator {+ transPtr :: ForeignPtr UTransliterator,+ transSpec :: Text+ }+++instance Show Transliterator where+ show tr = "Transliterator " ++ show (transSpec tr)++++transliterator :: Text -> IO Transliterator+transliterator spec =+ useAsPtr spec $ \ptr len -> do+ q <- handleError $ openTrans ptr (fromIntegral len)+ ref <- newForeignPtr closeTrans q+ touchForeignPtr ref+ return $ Transliterator ref spec+++transliterate :: Transliterator -> Text -> IO Text+transliterate tr txt = do+ (fptr, len) <- asForeignPtr txt+ withForeignPtr fptr $ \ptr ->+ withForeignPtr (transPtr tr) $ \tr_ptr -> do+ handleFilledOverflowError ptr (fromIntegral len)+ (\dptr dlen ->+ doTrans tr_ptr dptr (fromIntegral len) (fromIntegral dlen))+ (\dptr dlen ->+ fromPtr (castPtr dptr) (fromIntegral dlen))++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Antonio Nikishaev++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Antonio Nikishaev nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/trans.c view
@@ -0,0 +1,55 @@+#include <unicode/utrans.h>+#include <stdio.h>+#include "trans.h"++void *+__hs_translit_open_trans (const UChar *name, int len, UErrorCode *err)+{+ UTransliterator *tr = utrans_openU (name, len, UTRANS_FORWARD, 0, -1, 0, err);++ /* printf ("trans %p, err=%s\n", tr, u_errorName (*err)); */++ return tr;+}++void+__hs_translit_close_trans (UTransliterator *trans)+{+ /* printf ("close\n"); */+ utrans_close (trans);+}++int32_t+__hs_translit_do_trans (UTransliterator *trans, UChar *text, int32_t len,+ int32_t capacity, UErrorCode *err)+{+ /* int len0 = len; */+ int lim = len;++ utrans_transUChars (trans, text, &len, capacity, 0, &lim, err);++ /* printf ("trans len=lim=%d cap=%d -> len=%d lim=%d err=%d\n", */+ /* len0, capacity, len, lim, *err); */+ /* printf ("T: %s\n", u_errorName (*err)); */++ return lim;+}+++/* char *listTrans (UErrorCode *err) */+/* { */+/* UEnumeration *iter = utrans_openIDs (err); */+/* for (const char *x; x = uenum_next (iter, 0, err);) */+/* u_printf ("-%s\n", x); */++ +/* } */++++const char *+__hs_translit_u_errorName (UErrorCode code)+{+ return u_errorName(code);+}+
+ include/trans.h view
@@ -0,0 +1,11 @@++void *__hs_translit_open_trans (const UChar *name, int len, UErrorCode *err);+void __hs_translit_close_trans (UTransliterator *trans);++int32_t __hs_translit_do_trans (UTransliterator *trans,+ UChar *text, int32_t len,+ int32_t capacity, UErrorCode *err);++const char *__hs_translit_u_errorName (UErrorCode code);++
+ tests/Test.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++import Test.QuickCheck+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.ICU as U+import Data.Text.ICU.Translit+import Text.Printf+import Data.Char++import Test.Framework+import Test.Framework.Providers.QuickCheck2++-- newtype Random a = Random { unRandom :: a } deriving Show+++instance Arbitrary Text where+ arbitrary = fmap T.pack arbitrary+ shrink = fmap T.pack . shrink . T.unpack++-- instance Arbitrary a => Arbitrary (Random a) where+-- arbitrary = fmap Random arbitrary+++samples :: [Text]+samples = ["hello","текст","维基百科：海納百川，有容乃大"]+++newtype IdempTr = IdempTr Text deriving Show++++instance Arbitrary IdempTr where+ arbitrary = elements transes0+ where transes0 = map IdempTr ["ru-en", "en-ru"]++hexUnicode :: Text -> Text+hexUnicode txt = T.pack $ concat [ fmt c | c <- T.unpack txt ]+ where fmt c = printf (if ord c < 0x10000 then "U+%04X" else "U+%X") (ord c)+++prop_idemp (IdempTr t,s) = transliterate tr (transliterate tr s) == transliterate tr s+ where tr = trans t+prop_toLower' t = U.toLower U.Root t == transliterate (trans "Lower") t+prop_toLower t = T.toLower t == transliterate (trans "Lower") t+prop_NFC t = U.normalize U.NFC t == transliterate (trans "NFC") t+prop_hexUnicode t = hexUnicode t == transliterate (trans "hex/unicode") t++++main = defaultMain [tests]++tests :: Test+tests = testGroup "props" [+ testProperty "idemp" prop_idemp,+ testProperty "toLower'" prop_toLower',+ testProperty "toLower" prop_toLower,+ testProperty "NFC" prop_NFC,+ testProperty "hexUnicode" prop_hexUnicode+ ]++++
+ text-icu-translit.cabal view
@@ -0,0 +1,61 @@++name: text-icu-translit+version: 0.1.0.7+synopsis: ICU transliteration+description:+ Bindings to the transliteration features by the+ International Components for Unicode (ICU) library++license: BSD3+license-file: LICENSE+author: Antonio Nikishaev+maintainer: Antonio Nikishaev <me@lelf.lu>+copyright: 2014 Antonio Nikishaev+bug-reports: https://github.com/llelf/text-icu-translit/issues+category: Text+build-type: Simple+cabal-version: >=1.10+extra-source-files: include/trans.h++library+ exposed-modules: Data.Text.ICU.Translit+ other-modules: Data.Text.ICU.Translit.Internal,+ Data.Text.ICU.Translit.ICUHelper++ ghc-options: -Wall++ c-sources: cbits/trans.c+ include-dirs: include++ extra-libraries: icuuc+ if os(mingw32)+ extra-libraries: icuin icudt+ else+ extra-libraries: icui18n icudata++ -- other-extensions: + build-depends: base >=4 && <5, text >= 1.0+ -- hs-source-dirs: + default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ hs-source-dirs: tests+ main-is: Test.hs+ build-depends: base, text,+ text-icu >= 0.6.3,+ text-icu-translit,+ QuickCheck >= 2.4,+ test-framework >= 0.8,+ test-framework-quickcheck2 >= 0.3+++source-repository head+ type: darcs+ location: http://hub.darcs.net/lelf/text-icu-translit++source-repository head+ type: git+ location: https://github.com/llelf/text-icu-translit+