@@ -0,0 +1,48 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+
3+module Data.Text.Internal.CaseMapping
4+ (
5+ toUpper
6+ ) where
7+
8+import Data.Text.Internal.Unsafe.Char (ord, unsafeChr)
9+import Data.Text.Internal.Unsafe (inlinePerformIO)
10+import Data.Word (Word16)
11+import Foreign.Ptr (Ptr, plusPtr)
12+import Foreign.C.Types (CSize)
13+import Data.Text.Internal.Fusion.Types
14+import Foreign.Storable (peek)
15+import qualified Data.Char as Char
16+
17+search :: Ptr Word16 -> Int -> Word16 -> (Int -> IO a) -> IO a
18+search table len key cont = go 0 (len - 1)
19+ where
20+ go lo hi
21+ | hi < lo = cont (-1)
22+ | otherwise = do
23+ let mid = lo + (hi - lo) `quot` 2
24+ val <- peek (table `plusPtr` mid)
25+ case undefined of
26+ _ | val == key -> cont mid
27+ | val < key -> go (mid + 1) hi
28+ | otherwise -> go lo (mid - 1)
29+
30+toUpper :: Char -> s -> Step (CC s) Char
31+toUpper c s
32+ | c > '\xffff' = Yield (Char.toUpper c) (CC s '\0' '\0')
33+ | otherwise = inlinePerformIO $ do
34+ len <- fromIntegral `fmap` peek toUpperLen
35+ search toUpperKeys len (fromIntegral (ord c)) $ \idx -> do
36+ if (idx == -1)
37+ then return $ Yield (Char.toUpper c) (CC s '\0' '\0')
38+ else do
39+ let ptr = toUpperValues `plusPtr` (idx * 12)
40+ x <- unsafeChr `fmap` peek ptr
41+ y <- unsafeChr `fmap` peek (ptr `plusPtr` 2)
42+ z <- unsafeChr `fmap` peek (ptr `plusPtr` 4)
43+ return $ Yield x (CC s y z)
44+
45+
46+foreign import ccall "&_hs_text_to_upper_keys" toUpperKeys :: Ptr Word16
47+foreign import ccall "&_hs_text_to_upper_len" toUpperLen :: Ptr CSize
48+foreign import ccall "&_hs_text_to_upper_values" toUpperValues :: Ptr Word16