{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
module Data.Unicode.Internal.NormalizeStream
(
UC.DecomposeMode(..)
, stream
, unstream
, unstreamC
)
where
import Data.Char (chr, ord)
import GHC.ST (ST(..))
import GHC.Types (SPEC(..))
import qualified Data.Text.Array as A
import qualified Unicode.Char as UC
#if MIN_VERSION_text(2,0,0)
import Data.Text.Internal.Fusion (stream)
#else
import Data.Bits (shiftR)
import Data.Text.Internal.Unsafe.Char (unsafeChr)
import Data.Text.Internal.Fusion.Size (betweenSize)
import Data.Text.Internal.Encoding.Utf16 (chr2)
#endif
import Data.Text.Internal (Text(..))
import Data.Text.Internal.Fusion.Size (upperBound)
import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
import Data.Text.Internal.Private (runText)
import Data.Text.Internal.Unsafe.Char (unsafeWrite)
data ReBuf = Empty | One !Char | Many !Char !Char ![Char]
{-# INLINE insertIntoReBuf #-}
insertIntoReBuf :: Char -> ReBuf -> ReBuf
insertIntoReBuf :: Char -> ReBuf -> ReBuf
insertIntoReBuf Char
c ReBuf
Empty = Char -> ReBuf
One Char
c
insertIntoReBuf Char
c (One Char
c0)
| Char -> Int
UC.combiningClass Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c0
= Char -> Char -> [Char] -> ReBuf
Many Char
c Char
c0 []
| Bool
otherwise
= Char -> Char -> [Char] -> ReBuf
Many Char
c0 Char
c []
insertIntoReBuf Char
c (Many Char
c0 Char
c1 [Char]
cs)
| Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c0
= Char -> Char -> [Char] -> ReBuf
Many Char
c Char
c0 (Char
c1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs)
| Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c1
= Char -> Char -> [Char] -> ReBuf
Many Char
c0 Char
c (Char
c1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs)
| Bool
otherwise
= Char -> Char -> [Char] -> ReBuf
Many Char
c0 Char
c1 ([Char]
cs' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs''))
where
cc :: Int
cc = Char -> Int
UC.combiningClass Char
c
([Char]
cs', [Char]
cs'') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
cc) (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
UC.combiningClass) [Char]
cs
writeStr :: A.MArray s -> Int -> [Char] -> ST s Int
writeStr :: forall s. MArray s -> Int -> [Char] -> ST s Int
writeStr MArray s
marr Int
di [Char]
str = Int -> [Char] -> ST s Int
go Int
di [Char]
str
where
go :: Int -> [Char] -> ST s Int
go Int
i [] = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
go Int
i (Char
c : [Char]
cs) = do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
i Char
c
go (i + n) cs
{-# INLINE writeReorderBuffer #-}
writeReorderBuffer :: A.MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer :: forall s. MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer MArray s
_ Int
di ReBuf
Empty = Int -> ST s Int
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
di
writeReorderBuffer MArray s
marr Int
di (One Char
c) = do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
di Char
c
return (di + n)
writeReorderBuffer MArray s
marr Int
di (Many Char
c1 Char
c2 [Char]
str) = do
n1 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
di Char
c1
n2 <- unsafeWrite marr (di + n1) c2
writeStr marr (di + n1 + n2) str
decomposeCharHangul :: A.MArray s -> Int -> Char -> ST s Int
decomposeCharHangul :: forall s. MArray s -> Int -> Char -> ST s Int
decomposeCharHangul MArray s
marr Int
j Char
c =
if Char
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Char
chr Int
UC.jamoTFirst then do
n1 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
j Char
l
n2 <- unsafeWrite marr (j + n1) v
return (j + n1 + n2)
else do
n1 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
j Char
l
n2 <- unsafeWrite marr (j + n1) v
n3 <- unsafeWrite marr (j + n1 + n2) t
return (j + n1 + n2 + n3)
where
(Char
l, Char
v, Char
t) = Char -> (Char, Char, Char)
UC.decomposeHangul Char
c
{-# INLINE decomposeChar #-}
decomposeChar
:: UC.DecomposeMode
-> A.MArray s
-> Int
-> ReBuf
-> Char
-> ST s (Int, ReBuf)
decomposeChar :: forall s.
DecomposeMode
-> MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
decomposeChar DecomposeMode
mode MArray s
marr Int
index ReBuf
reBuf Char
ch
| Char -> Bool
UC.isHangul Char
ch = do
j <- MArray s -> Int -> ReBuf -> ST s Int
forall s. MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer MArray s
marr Int
index ReBuf
reBuf
(, Empty) <$> decomposeCharHangul marr j ch
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch =
MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
forall {s}.
MutableByteArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MArray s
marr Int
index ReBuf
reBuf (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch)
| Bool
otherwise =
MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
forall {s}. MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
reorder MArray s
marr Int
index ReBuf
reBuf Char
ch
where
{-# INLINE decomposeAll #-}
decomposeAll :: MutableByteArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MutableByteArray s
_ Int
i ReBuf
rbuf [] = (Int, ReBuf) -> ST s (Int, ReBuf)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, ReBuf
rbuf)
decomposeAll MutableByteArray s
arr Int
i ReBuf
rbuf (Char
x : [Char]
xs)
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
x = do
(i', rbuf') <- MutableByteArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MutableByteArray s
arr Int
i ReBuf
rbuf (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
x)
decomposeAll arr i' rbuf' xs
| Bool
otherwise = do
(i', rbuf') <- MutableByteArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
forall {s}. MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
reorder MutableByteArray s
arr Int
i ReBuf
rbuf Char
x
decomposeAll arr i' rbuf' xs
{-# INLINE reorder #-}
reorder :: MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
reorder MArray s
arr Int
i ReBuf
rbuf Char
c
| Char -> Bool
UC.isCombining Char
c = (Int, ReBuf) -> ST s (Int, ReBuf)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, Char -> ReBuf -> ReBuf
insertIntoReBuf Char
c ReBuf
rbuf)
| Bool
otherwise = do
j <- MArray s -> Int -> ReBuf -> ST s Int
forall s. MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer MArray s
arr Int
i ReBuf
rbuf
n <- unsafeWrite arr j c
return (j + n, Empty)
#if !MIN_VERSION_text(2,0,0)
stream :: Text -> Stream Char
stream (Text arr off len) = Stream next off (betweenSize (len `shiftR` 1) len)
where
!end = off+len
{-# INLINE next #-}
next !i
| i >= end = Done
| (n `shiftR` 10) == 0x36 = Yield (chr2 n n2) (i + 2)
| otherwise = Yield (unsafeChr n) (i + 1)
where
n = A.unsafeIndex arr i
n2 = A.unsafeIndex arr (i + 1)
{-# INLINE [0] stream #-}
#endif
unstream :: UC.DecomposeMode -> Stream Char -> Text
unstream :: DecomposeMode -> Stream Char -> Text
unstream DecomposeMode
mode (Stream s -> Step s Char
next0 s
s0 Size
len) = (forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text
runText ((forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text)
-> (forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text
forall a b. (a -> b) -> a -> b
$ \MArray s -> Int -> ST s Text
done -> do
let margin :: Int
margin = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxDecomposeLen
mlen :: Int
mlen = (Int -> Size -> Int
upperBound Int
4 Size
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin)
arr0 <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
mlen
let outer !MArray s
arr !Int
maxi = s -> Int -> ReBuf -> ST s Text
encode
where
encode :: s -> Int -> ReBuf -> ST s Text
encode !s
si !Int
di ReBuf
rbuf =
if Int
maxi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
di Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin
then s -> Int -> ReBuf -> ST s Text
realloc s
si Int
di ReBuf
rbuf
else
case s -> Step s Char
next0 s
si of
Step s Char
Done -> do
di' <- MArray s -> Int -> ReBuf -> ST s Int
forall s. MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer MArray s
arr Int
di ReBuf
rbuf
done arr di'
Skip s
si' -> s -> Int -> ReBuf -> ST s Text
encode s
si' Int
di ReBuf
rbuf
Yield Char
c s
si' -> do
(di', rbuf') <- DecomposeMode
-> MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
forall s.
DecomposeMode
-> MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
decomposeChar DecomposeMode
mode MArray s
arr Int
di ReBuf
rbuf Char
c
encode si' di' rbuf'
{-# NOINLINE realloc #-}
realloc :: s -> Int -> ReBuf -> ST s Text
realloc !s
si !Int
di ReBuf
rbuf = do
let newlen :: Int
newlen = Int
maxi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
arr' <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
newlen
A.copyM arr' 0 arr 0 di
outer arr' (newlen - 1) si di rbuf
outer arr0 (mlen - 1) s0 0 Empty
{-# INLINE [0] unstream #-}
maxDecomposeLen :: Int
maxDecomposeLen :: Int
maxDecomposeLen = Int
32
data JamoBuf
= Jamo !Char
| Hangul !Char
| HangulLV !Char
data RegBuf
= RegOne !Char
| RegMany !Char !Char ![Char]
data ComposeState
= ComposeNone
| ComposeReg !RegBuf
| ComposeJamo !JamoBuf
{-# INLINE writeJamoBuf #-}
writeJamoBuf :: A.MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf :: forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
arr Int
i JamoBuf
jbuf = do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
i (JamoBuf -> Char
getCh JamoBuf
jbuf)
return (i + n)
where
getCh :: JamoBuf -> Char
getCh (Jamo Char
ch) = Char
ch
getCh (Hangul Char
ch) = Char
ch
getCh (HangulLV Char
ch) = Char
ch
{-# INLINE initHangul #-}
initHangul :: Char -> Int -> ST s (Int, ComposeState)
initHangul :: forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
c Int
i = (Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
Hangul Char
c))
{-# INLINE initJamo #-}
initJamo :: Char -> Int -> ST s (Int, ComposeState)
initJamo :: forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
c Int
i = (Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
Jamo Char
c))
{-# INLINE insertJamo #-}
insertJamo
:: A.MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertJamo :: forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertJamo MArray s
arr Int
i JamoBuf
jbuf Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoLLast = do
j <- MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
arr Int
i JamoBuf
jbuf
return (j, ComposeJamo (Jamo ch))
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.jamoVFirst =
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
flushAndWrite MArray s
arr Int
i JamoBuf
jbuf Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoVLast = do
case JamoBuf
jbuf of
Jamo Char
c ->
case Char -> Maybe Int
UC.jamoLIndex Char
c of
Just Int
li ->
let vi :: Int
vi = Int
ich Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
UC.jamoVFirst
lvi :: Int
lvi = Int
li Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
UC.jamoNCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
vi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
UC.jamoTCount
lv :: Char
lv = Int -> Char
chr (Int
UC.hangulFirst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lvi)
in (Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
HangulLV Char
lv))
Maybe Int
Nothing -> MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
arr Int
i Char
c Char
ch
Hangul Char
c -> MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
arr Int
i Char
c Char
ch
HangulLV Char
c -> MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
arr Int
i Char
c Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoTFirst = do
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
flushAndWrite MArray s
arr Int
i JamoBuf
jbuf Char
ch
| Bool
otherwise = do
let ti :: Int
ti = Int
ich Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
UC.jamoTFirst
case JamoBuf
jbuf of
Jamo Char
c -> MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
arr Int
i Char
c Char
ch
Hangul Char
c
| Char -> Bool
UC.isHangulLV Char
c -> do
MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
writeLVT MArray s
arr Int
i Char
c Int
ti
| Bool
otherwise ->
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
arr Int
i Char
c Char
ch
HangulLV Char
c ->
MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
forall {s}.
MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
writeLVT MArray s
arr Int
i Char
c Int
ti
where
ich :: Int
ich = Char -> Int
ord Char
ch
{-# INLINE flushAndWrite #-}
flushAndWrite :: MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
flushAndWrite MArray s
marr Int
ix JamoBuf
jb Char
c = do
j <- MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
marr Int
ix JamoBuf
jb
n <- unsafeWrite marr j c
return (j + n, ComposeNone)
{-# INLINE writeLVT #-}
writeLVT :: MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
writeLVT MArray s
marr Int
ix Char
lv Int
ti = do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
ix (Int -> Char
chr ((Char -> Int
ord Char
lv) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ti))
return (ix + n, ComposeNone)
{-# INLINE writeTwo #-}
writeTwo :: MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo MArray s
marr Int
ix Char
c1 Char
c2 = do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
ix Char
c1
m <- unsafeWrite marr (ix + n) c2
return ((ix + n + m), ComposeNone)
{-# INLINE insertHangul #-}
insertHangul
:: A.MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul :: forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul MArray s
arr Int
i JamoBuf
jbuf Char
ch = do
j <- MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
arr Int
i JamoBuf
jbuf
return (j, ComposeJamo (Hangul ch))
{-# INLINE insertIntoRegBuf #-}
insertIntoRegBuf :: Char -> RegBuf -> RegBuf
insertIntoRegBuf :: Char -> RegBuf -> RegBuf
insertIntoRegBuf Char
c (RegOne Char
c0)
| Char -> Int
UC.combiningClass Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c0
= Char -> Char -> [Char] -> RegBuf
RegMany Char
c Char
c0 []
| Bool
otherwise
= Char -> Char -> [Char] -> RegBuf
RegMany Char
c0 Char
c []
insertIntoRegBuf Char
c (RegMany Char
c0 Char
c1 [Char]
cs)
| Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c0
= Char -> Char -> [Char] -> RegBuf
RegMany Char
c Char
c0 (Char
c1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs)
| Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
UC.combiningClass Char
c1
= Char -> Char -> [Char] -> RegBuf
RegMany Char
c0 Char
c (Char
c1 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs)
| Bool
otherwise
= Char -> Char -> [Char] -> RegBuf
RegMany Char
c0 Char
c1 ([Char]
cs' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs''))
where
cc :: Int
cc = Char -> Int
UC.combiningClass Char
c
([Char]
cs', [Char]
cs'') = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
cc) (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
UC.combiningClass) [Char]
cs
{-# INLINE writeRegBuf #-}
writeRegBuf :: A.MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf :: forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
arr Int
i = \case
RegOne Char
c -> do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
i Char
c
return (i + n)
RegMany Char
st Char
c [] ->
case Char -> Char -> Maybe Char
UC.compose Char
st Char
c of
Just Char
x -> do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
i Char
x
return (i + n)
Maybe Char
Nothing -> do
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
i Char
st
m <- unsafeWrite arr (i + n) c
return (i + n + m)
RegMany Char
st0 Char
c0 [Char]
cs0 -> [Char] -> Char -> [Char] -> ST s Int
go [] Char
st0 (Char
c0 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs0)
where
go :: [Char] -> Char -> [Char] -> ST s Int
go [Char]
uncs Char
st [] = MArray s -> Int -> [Char] -> ST s Int
forall s. MArray s -> Int -> [Char] -> ST s Int
writeStr MArray s
arr Int
i (Char
st Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
uncs)
go [Char]
uncs Char
st (Char
c : [Char]
cs) = case Char -> Char -> Maybe Char
UC.compose Char
st Char
c of
Maybe Char
Nothing -> [Char] -> Char -> [Char] -> ST s Int
go ([Char]
uncs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
same)) Char
st [Char]
bigger
Just Char
x -> [Char] -> Char -> [Char] -> ST s Int
go [Char]
uncs Char
x [Char]
cs
where
cc :: Int
cc = Char -> Int
UC.combiningClass Char
c
([Char]
same, [Char]
bigger) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
cc) (Int -> Bool) -> (Char -> Int) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
UC.combiningClass) [Char]
cs
{-# INLINE flushComposeState #-}
flushComposeState :: A.MArray s -> Int -> ComposeState -> ST s Int
flushComposeState :: forall s. MArray s -> Int -> ComposeState -> ST s Int
flushComposeState MArray s
arr Int
i = \case
ComposeState
ComposeNone -> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
ComposeReg RegBuf
rbuf -> MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
arr Int
i RegBuf
rbuf
ComposeJamo JamoBuf
jbuf -> MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
arr Int
i JamoBuf
jbuf
{-# INLINE composeChar #-}
composeChar
:: UC.DecomposeMode
-> A.MArray s
-> Char
-> Int
-> ComposeState
-> ST s (Int, ComposeState)
composeChar :: forall s.
DecomposeMode
-> MArray s
-> Char
-> Int
-> ComposeState
-> ST s (Int, ComposeState)
composeChar DecomposeMode
mode MArray s
marr = Char -> Int -> ComposeState -> ST s (Int, ComposeState)
go0
where
go0 :: Char -> Int -> ComposeState -> ST s (Int, ComposeState)
go0 Char
ch !Int
i !ComposeState
st =
case ComposeState
st of
ComposeReg RegBuf
rbuf
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.jamoLFirst ->
RegBuf -> Char -> Int -> ComposeState -> ST s (Int, ComposeState)
composeReg RegBuf
rbuf Char
ch Int
i ComposeState
st
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoTLast -> do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
initJamo ch j
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.hangulFirst ->
RegBuf -> Char -> Int -> ComposeState -> ST s (Int, ComposeState)
composeReg RegBuf
rbuf Char
ch Int
i ComposeState
st
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.hangulLast -> do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
initHangul ch j
| Bool
otherwise ->
RegBuf -> Char -> Int -> ComposeState -> ST s (Int, ComposeState)
composeReg RegBuf
rbuf Char
ch Int
i ComposeState
st
ComposeJamo JamoBuf
jbuf
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.jamoLFirst -> do
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
jamoToReg MArray s
marr Int
i JamoBuf
jbuf Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoTLast -> do
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertJamo MArray s
marr Int
i JamoBuf
jbuf Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.hangulFirst ->
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
jamoToReg MArray s
marr Int
i JamoBuf
jbuf Char
ch
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.hangulLast -> do
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul MArray s
marr Int
i JamoBuf
jbuf Char
ch
| Bool
otherwise ->
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
jamoToReg MArray s
marr Int
i JamoBuf
jbuf Char
ch
ComposeState
ComposeNone
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.jamoLFirst ->
Char -> Int -> ST s (Int, ComposeState)
initReg Char
ch Int
i
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.jamoTLast ->
Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
ch Int
i
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
UC.hangulFirst ->
Char -> Int -> ST s (Int, ComposeState)
initReg Char
ch Int
i
| Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
UC.hangulLast ->
Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
ch Int
i
| Bool
otherwise ->
Char -> Int -> ST s (Int, ComposeState)
initReg Char
ch Int
i
where ich :: Int
ich = Char -> Int
ord Char
ch
{-# INLINE jamoToReg #-}
jamoToReg :: MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
jamoToReg MArray s
arr Int
i JamoBuf
jbuf Char
ch = do
j <- MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
arr Int
i JamoBuf
jbuf
initReg ch j
{-# INLINE initReg #-}
initReg :: Char -> Int -> ST s (Int, ComposeState)
initReg !Char
ch !Int
i
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch =
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch) Int
i ComposeState
ComposeNone
| Bool
otherwise =
(Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
ch))
{-# INLINE composeReg #-}
composeReg :: RegBuf -> Char -> Int -> ComposeState -> ST s (Int, ComposeState)
composeReg RegBuf
rbuf !Char
ch !Int
i !ComposeState
st
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch =
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch) Int
i ComposeState
st
| Char -> Bool
UC.isCombining Char
ch = do
(Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, RegBuf -> ComposeState
ComposeReg (Char -> RegBuf -> RegBuf
insertIntoRegBuf Char
ch RegBuf
rbuf))
| RegOne Char
s <- RegBuf
rbuf
, Char -> Bool
UC.isCombiningStarter Char
ch
, Just Char
x <- Char -> Char -> Maybe Char
UC.composeStarters Char
s Char
ch =
(Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
x)))
| Bool
otherwise = do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
pure (j, ComposeReg (RegOne ch))
go :: [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [] !Int
i !ComposeState
st = (Int, ComposeState) -> ST s (Int, ComposeState)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, ComposeState
st)
go (Char
ch : [Char]
rest) Int
i ComposeState
st =
case ComposeState
st of
ComposeReg RegBuf
rbuf
| Char -> Bool
UC.isHangul Char
ch -> do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
(k, s) <- initHangul ch j
go rest k s
| Char -> Bool
UC.isJamo Char
ch -> do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
(k, s) <- initJamo ch j
go rest k s
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest) Int
i ComposeState
st
| Char -> Bool
UC.isCombining Char
ch -> do
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
i (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf -> RegBuf
insertIntoRegBuf Char
ch RegBuf
rbuf))
| RegOne Char
s <- RegBuf
rbuf
, Char -> Bool
UC.isCombiningStarter Char
ch
, Just Char
x <- Char -> Char -> Maybe Char
UC.composeStarters Char
s Char
ch ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
i (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
x))
| Bool
otherwise -> do
j <- MArray s -> Int -> RegBuf -> ST s Int
forall s. MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf MArray s
marr Int
i RegBuf
rbuf
go rest j (ComposeReg (RegOne ch))
ComposeJamo JamoBuf
jbuf
| Char -> Bool
UC.isJamo Char
ch -> do
(j, s) <- MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertJamo MArray s
marr Int
i JamoBuf
jbuf Char
ch
go rest j s
| Char -> Bool
UC.isHangul Char
ch -> do
(j, s) <- MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
forall s.
MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul MArray s
marr Int
i JamoBuf
jbuf Char
ch
go rest j s
| Bool
otherwise -> do
j <- MArray s -> Int -> JamoBuf -> ST s Int
forall s. MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf MArray s
marr Int
i JamoBuf
jbuf
case () of
()
_
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest) Int
j
ComposeState
ComposeNone
| Bool
otherwise ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
ch))
ComposeState
ComposeNone
| Char -> Bool
UC.isHangul Char
ch -> do
(j, s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
ch Int
i
go rest j s
| Char -> Bool
UC.isJamo Char
ch -> do
(j, s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
ch Int
i
go rest j s
| DecomposeMode -> Char -> Bool
UC.isDecomposable DecomposeMode
mode Char
ch ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
UC.decompose DecomposeMode
mode Char
ch [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest) Int
i ComposeState
st
| Bool
otherwise ->
[Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
i (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
ch))
unstreamC :: UC.DecomposeMode -> Stream Char -> Text
unstreamC :: DecomposeMode -> Stream Char -> Text
unstreamC DecomposeMode
mode (Stream s -> Step s Char
next0 s
s0 Size
len) = (forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text
runText ((forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text)
-> (forall s. (MArray s -> Int -> ST s Text) -> ST s Text) -> Text
forall a b. (a -> b) -> a -> b
$ \MArray s -> Int -> ST s Text
done -> do
let margin :: Int
margin = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxDecomposeLen
mlen :: Int
mlen = (Int -> Size -> Int
upperBound Int
4 Size
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin)
arr0 <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
mlen
let outer !MArray s
arr !Int
maxi = SPEC -> s -> Int -> ComposeState -> ST s Text
encode SPEC
SPEC
where
encode :: SPEC -> s -> Int -> ComposeState -> ST s Text
encode !SPEC
_ !s
si !Int
di ComposeState
st =
if Int
maxi Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
di Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin
then s -> Int -> ComposeState -> ST s Text
realloc s
si Int
di ComposeState
st
else
case s -> Step s Char
next0 s
si of
Step s Char
Done -> do
di' <- MArray s -> Int -> ComposeState -> ST s Int
forall s. MArray s -> Int -> ComposeState -> ST s Int
flushComposeState MArray s
arr Int
di ComposeState
st
done arr di'
Skip s
si' -> SPEC -> s -> Int -> ComposeState -> ST s Text
encode SPEC
SPEC s
si' Int
di ComposeState
st
Yield Char
c s
si' -> do
(di', st') <- DecomposeMode
-> MArray s
-> Char
-> Int
-> ComposeState
-> ST s (Int, ComposeState)
forall s.
DecomposeMode
-> MArray s
-> Char
-> Int
-> ComposeState
-> ST s (Int, ComposeState)
composeChar DecomposeMode
mode MArray s
arr Char
c Int
di ComposeState
st
encode SPEC si' di' st'
{-# NOINLINE realloc #-}
realloc :: s -> Int -> ComposeState -> ST s Text
realloc !s
si !Int
di ComposeState
st = do
let newlen :: Int
newlen = Int
maxi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
arr' <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
newlen
A.copyM arr' 0 arr 0 di
outer arr' (newlen - 1) si di st
outer arr0 (mlen - 1) s0 0 ComposeNone
{-# INLINE [0] unstreamC #-}