{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
-- |
-- Module      : Data.Unicode.Internal.NormalizeStream
-- Copyright   : (c) 2016 Harendra Kumar
--               (c) 2020 Andrew Lelechenko
--
-- License     : BSD-3-Clause
-- Maintainer  : harendra.kumar@gmail.com
-- Stability   : experimental
--
-- Stream based normalization.
--
module Data.Unicode.Internal.NormalizeStream
    (
      D.DecomposeMode(..)
    , stream
    , unstream
    , unstreamC
    )
    where

import           Data.Char                              (chr, ord)
import qualified Data.Text.Array                        as A
import           Data.Text.Internal                     (Text (..))
import qualified Data.Text.Internal.Encoding.Utf16      as U16
import           Data.Text.Internal.Fusion.Size         (betweenSize,
                                                         upperBound)
import           Data.Text.Internal.Fusion.Types        (Step (..), Stream (..))
import           Data.Text.Internal.Private             (runText)
import           Data.Text.Internal.Unsafe.Char         (unsafeWrite)
import           Data.Text.Internal.Unsafe.Char         (unsafeChr)
import           Data.Text.Internal.Unsafe.Shift        (shiftR)
import           GHC.ST                                 (ST (..))
import           GHC.Types                              (SPEC(..))

import qualified Data.Unicode.Properties.CombiningClass  as CC
import qualified Data.Unicode.Properties.Compositions    as C
import qualified Data.Unicode.Properties.Decompose       as D
import qualified Data.Unicode.Properties.DecomposeHangul as H

-------------------------------------------------------------------------------
-- Reorder buffer to hold characters till the next starter boundary
-------------------------------------------------------------------------------

-- | A list of combining characters, ordered by 'CC.getCombiningClass'.
-- Couple of top levels are unrolled and unpacked for efficiency.
data ReBuf = Empty | One !Char | Many !Char !Char ![Char]

{-# INLINE insertIntoReBuf #-}
insertIntoReBuf :: Char -> ReBuf -> ReBuf
insertIntoReBuf :: Char -> ReBuf -> ReBuf
insertIntoReBuf c :: Char
c Empty = Char -> ReBuf
One Char
c
insertIntoReBuf c :: Char
c (One c0 :: Char
c0)
    | Char -> Int
CC.getCombiningClass Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
CC.getCombiningClass Char
c0
    = Char -> Char -> [Char] -> ReBuf
Many Char
c Char
c0 []
    | Bool
otherwise
    = Char -> Char -> [Char] -> ReBuf
Many Char
c0 Char
c []
insertIntoReBuf c :: Char
c (Many c0 :: Char
c0 c1 :: Char
c1 cs :: [Char]
cs)
    | Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
CC.getCombiningClass 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
CC.getCombiningClass 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
CC.getCombiningClass Char
c
        (cs' :: [Char]
cs', 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
CC.getCombiningClass) [Char]
cs

writeStr :: A.MArray s -> Int -> [Char] -> ST s Int
writeStr :: MArray s -> Int -> [Char] -> ST s Int
writeStr marr :: MArray s
marr di :: Int
di str :: [Char]
str = Int -> [Char] -> ST s Int
go Int
di [Char]
str
    where
        go :: Int -> [Char] -> ST s Int
go i :: Int
i [] = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
        go i :: Int
i (c :: Char
c : cs :: [Char]
cs) = do
            Int
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
            Int -> [Char] -> ST s Int
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) [Char]
cs

{-# INLINE writeReorderBuffer #-}
writeReorderBuffer :: A.MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer :: MArray s -> Int -> ReBuf -> ST s Int
writeReorderBuffer _ di :: Int
di Empty = Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
di

writeReorderBuffer marr :: MArray s
marr di :: Int
di (One c :: Char
c) = do
    Int
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
    Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
di Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

writeReorderBuffer marr :: MArray s
marr di :: Int
di (Many c1 :: Char
c1 c2 :: Char
c2 str :: [Char]
str) = do
    Int
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
    Int
n2 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
di Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1) Char
c2
    MArray s -> Int -> [Char] -> ST s Int
forall s. MArray s -> Int -> [Char] -> ST s Int
writeStr MArray s
marr (Int
di Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) [Char]
str

-------------------------------------------------------------------------------
-- Decomposition of Hangul characters is done algorithmically
-------------------------------------------------------------------------------

-- {-# INLINE decomposeCharHangul #-}
decomposeCharHangul :: A.MArray s -> Int -> Char -> ST s Int
decomposeCharHangul :: MArray s -> Int -> Char -> ST s Int
decomposeCharHangul marr :: MArray s
marr j :: Int
j c :: Char
c =
    if Char
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Char
chr Int
H.jamoTFirst then do
        Int
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
        Int
n2 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1) Char
v
        Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2)
    else do
        Int
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
        Int
n2 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1) Char
v
        Int
n3 <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2) Char
t
        Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n3)
    where
        (l :: Char
l, v :: Char
v, t :: Char
t) = Char -> (Char, Char, Char)
D.decomposeCharHangul Char
c

{-# INLINE decomposeChar #-}
decomposeChar
    :: D.DecomposeMode
    -> A.MArray s       -- destination array for decomposition
    -> Int              -- array index
    -> ReBuf            -- reorder buffer
    -> Char             -- char to be decomposed
    -> ST s (Int, ReBuf)
decomposeChar :: DecomposeMode
-> MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
decomposeChar mode :: DecomposeMode
mode marr :: MArray s
marr index :: Int
index reBuf :: ReBuf
reBuf ch :: Char
ch
    | Char -> Bool
D.isHangul Char
ch = do
        Int
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
        (, ReBuf
Empty) (Int -> (Int, ReBuf)) -> ST s Int -> ST s (Int, ReBuf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
decomposeCharHangul MArray s
marr Int
j Char
ch
    | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
ch =
        MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
forall s. MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MArray s
marr Int
index ReBuf
reBuf (DecomposeMode -> Char -> [Char]
D.decomposeChar 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 :: MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll _ i :: Int
i rbuf :: ReBuf
rbuf [] = (Int, ReBuf) -> ST s (Int, ReBuf)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, ReBuf
rbuf)
    decomposeAll arr :: MArray s
arr i :: Int
i rbuf :: ReBuf
rbuf (x :: Char
x : xs :: [Char]
xs)
        | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
x = do
            (i' :: Int
i', rbuf' :: ReBuf
rbuf') <- MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MArray s
arr Int
i ReBuf
rbuf (DecomposeMode -> Char -> [Char]
D.decomposeChar DecomposeMode
mode Char
x)
            MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MArray s
arr Int
i' ReBuf
rbuf' [Char]
xs
        | Bool
otherwise  = do
            (i' :: Int
i', rbuf' :: ReBuf
rbuf') <- MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
forall s. MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
reorder MArray s
arr Int
i ReBuf
rbuf Char
x
            MArray s -> Int -> ReBuf -> [Char] -> ST s (Int, ReBuf)
decomposeAll MArray s
arr Int
i' ReBuf
rbuf' [Char]
xs

    {-# INLINE reorder #-}
    reorder :: MArray s -> Int -> ReBuf -> Char -> ST s (Int, ReBuf)
reorder arr :: MArray s
arr i :: Int
i rbuf :: ReBuf
rbuf c :: Char
c
        | Char -> Bool
CC.isCombining Char
c = (Int, ReBuf) -> ST s (Int, ReBuf)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, Char -> ReBuf -> ReBuf
insertIntoReBuf Char
c ReBuf
rbuf)
        | Bool
otherwise = do
            Int
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
            Int
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr Int
j Char
c
            (Int, ReBuf) -> ST s (Int, ReBuf)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, ReBuf
Empty)

-- | /O(n)/ Convert a 'Text' into a 'Stream Char'.
stream :: Text -> Stream Char
stream :: Text -> Stream Char
stream (Text arr :: Array
arr off :: Int
off len :: Int
len) = (Int -> Step Int Char) -> Int -> Size -> Stream Char
forall a s. (s -> Step s a) -> s -> Size -> Stream a
Stream Int -> Step Int Char
next Int
off (Int -> Int -> Size
betweenSize (Int
len Int -> Int -> Int
forall a. UnsafeShift a => a -> Int -> a
`shiftR` 1) Int
len)
    where
      !end :: Int
end = Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
len
      {-# INLINE next #-}
      next :: Int -> Step Int Char
next !Int
i
          | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
end                   = Step Int Char
forall s a. Step s a
Done
          -- shift generates only two branches instead of three in case of
          -- range check, works quite a bit faster with llvm backend.
          | (Word16
n Word16 -> Int -> Word16
forall a. UnsafeShift a => a -> Int -> a
`shiftR` 10) Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x36    = Char -> Int -> Step Int Char
forall s a. a -> s -> Step s a
Yield (Word16 -> Word16 -> Char
U16.chr2 Word16
n Word16
n2) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2)
          | Bool
otherwise                  = Char -> Int -> Step Int Char
forall s a. a -> s -> Step s a
Yield (Word16 -> Char
unsafeChr Word16
n) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
          where
            n :: Word16
n  = Array -> Int -> Word16
A.unsafeIndex Array
arr Int
i
            n2 :: Word16
n2 = Array -> Int -> Word16
A.unsafeIndex Array
arr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
{-# INLINE [0] stream #-}

-- | /O(n)/ Convert a 'Stream Char' into a decompose-normalized 'Text'.
unstream :: D.DecomposeMode -> Stream Char -> Text
unstream :: DecomposeMode -> Stream Char -> Text
unstream mode :: DecomposeMode
mode (Stream next0 :: s -> Step s Char
next0 s0 :: s
s0 len :: 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
$ \done :: MArray s -> Int -> ST s Text
done -> do
  -- Before encoding each char we perform a buffer realloc check assuming
  -- worst case encoding size of two 16-bit units for the char. Just add an
  -- extra space to the buffer so that we do not end up reallocating even when
  -- all the chars are encoded as single unit.
  let margin :: Int
margin = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxDecomposeLen
      mlen :: Int
mlen = (Int -> Size -> Int
upperBound 4 Size
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin)
  MArray s
arr0 <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
mlen
  let outer :: MArray s -> Int -> s -> Int -> ReBuf -> ST s Text
outer !MArray s
arr !Int
maxi = s -> Int -> ReBuf -> ST s Text
encode
       where
        -- keep the common case loop as small as possible
        encode :: s -> Int -> ReBuf -> ST s Text
encode !s
si !Int
di rbuf :: ReBuf
rbuf =
            -- simply check for the worst case
            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
                    Done -> do
                        Int
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
                        MArray s -> Int -> ST s Text
done MArray s
arr Int
di'
                    Skip si' :: s
si'    -> s -> Int -> ReBuf -> ST s Text
encode s
si' Int
di ReBuf
rbuf
                    Yield c :: Char
c si' :: s
si' -> do
                                (di' :: Int
di', rbuf' :: ReBuf
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
                                s -> Int -> ReBuf -> ST s Text
encode s
si' Int
di' ReBuf
rbuf'
                                -- n <- unsafeWrite arr di c
                                -- encode si' (di + n) rbuf

        -- keep uncommon case separate from the common case code
        {-# NOINLINE realloc #-}
        realloc :: s -> Int -> ReBuf -> ST s Text
realloc !s
si !Int
di rbuf :: ReBuf
rbuf = do
            let newlen :: Int
newlen = Int
maxi Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2
            MArray s
arr' <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
newlen
            MArray s -> Int -> MArray s -> Int -> Int -> ST s ()
forall s. MArray s -> Int -> MArray s -> Int -> Int -> ST s ()
A.copyM MArray s
arr' 0 MArray s
arr 0 Int
di
            MArray s -> Int -> s -> Int -> ReBuf -> ST s Text
outer MArray s
arr' (Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) s
si Int
di ReBuf
rbuf

  MArray s -> Int -> s -> Int -> ReBuf -> ST s Text
outer MArray s
arr0 (Int
mlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) s
s0 0 ReBuf
Empty
{-# INLINE [0] unstream #-}

-- we can generate this from UCD
maxDecomposeLen :: Int
maxDecomposeLen :: Int
maxDecomposeLen = 32

-------------------------------------------------------------------------------
-- Composition
-------------------------------------------------------------------------------

-- If we are composing we do not need to first decompose Hangul. We can just
-- compose assuming there could be some partially composed syllables e.g. LV
-- syllable followed by a jamo T. We need to compose this case as well.

-- Hold an L to wait for V, hold an LV to wait for T.
data JamoBuf
    = Jamo !Char -- Jamo L, V or T
    | Hangul !Char -- Hangul Syllable LV or LVT
    | HangulLV !Char

data RegBuf
    = RegOne !Char
    | RegMany !Char !Char ![Char]

data ComposeState
    = ComposeNone
    | ComposeReg !RegBuf
    | ComposeJamo !JamoBuf

-------------------------------------------------------------------------------
-- Composition of Jamo into Hangul syllables, done algorithmically
-------------------------------------------------------------------------------

{-# INLINE writeJamoBuf #-}
writeJamoBuf :: A.MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf :: MArray s -> Int -> JamoBuf -> ST s Int
writeJamoBuf arr :: MArray s
arr i :: Int
i jbuf :: JamoBuf
jbuf = do
    Int
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)
    Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)

    where

    getCh :: JamoBuf -> Char
getCh (Jamo ch :: Char
ch) = Char
ch
    getCh (Hangul ch :: Char
ch) = Char
ch
    getCh (HangulLV ch :: Char
ch) = Char
ch

{-# INLINE initHangul #-}
initHangul :: Char -> Int -> ST s (Int, ComposeState)
initHangul :: Char -> Int -> ST s (Int, ComposeState)
initHangul c :: Char
c i :: Int
i = (Int, ComposeState) -> ST s (Int, ComposeState)
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 :: Char -> Int -> ST s (Int, ComposeState)
initJamo c :: Char
c i :: Int
i = (Int, ComposeState) -> ST s (Int, ComposeState)
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 :: MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertJamo arr :: MArray s
arr i :: Int
i jbuf :: JamoBuf
jbuf ch :: Char
ch
    | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
H.jamoLLast = do
        Int
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
        (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
Jamo Char
ch))
    | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
H.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
H.jamoVLast = do
        case JamoBuf
jbuf of
            Jamo c :: Char
c ->
                case Char -> Maybe Int
H.jamoLIndex Char
c of
                    Just li :: Int
li ->
                        let vi :: Int
vi = Int
ich Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
H.jamoVFirst
                            lvi :: Int
lvi = Int
li Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
H.jamoNCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
vi Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
H.jamoTCount
                            lv :: Char
lv = Int -> Char
chr (Int
H.hangulFirst Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lvi)
                         in (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
HangulLV Char
lv))
                    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 c :: 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 c :: 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
H.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
H.jamoTFirst
        case JamoBuf
jbuf of
            Jamo c :: 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 c :: Char
c
                | Char -> Bool
H.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 c :: 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 marr :: MArray s
marr ix :: Int
ix jb :: JamoBuf
jb c :: Char
c = do
        Int
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
        Int
n <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr Int
j Char
c
        (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, ComposeState
ComposeNone)

    {-# INLINE writeLVT #-}
    writeLVT :: MArray s -> Int -> Char -> Int -> ST s (Int, ComposeState)
writeLVT marr :: MArray s
marr ix :: Int
ix lv :: Char
lv ti :: Int
ti = do
        Int
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))
        (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n, ComposeState
ComposeNone)

    {-# INLINE writeTwo #-}
    writeTwo :: MArray s -> Int -> Char -> Char -> ST s (Int, ComposeState)
writeTwo marr :: MArray s
marr ix :: Int
ix c1 :: Char
c1 c2 :: Char
c2 = do
        Int
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
        Int
m <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
marr (Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Char
c2
        (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m), ComposeState
ComposeNone)

{-# INLINE insertHangul #-}
insertHangul
    :: A.MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul :: MArray s -> Int -> JamoBuf -> Char -> ST s (Int, ComposeState)
insertHangul arr :: MArray s
arr i :: Int
i jbuf :: JamoBuf
jbuf ch :: Char
ch = do
    Int
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
    (Int, ComposeState) -> ST s (Int, ComposeState)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
j, JamoBuf -> ComposeState
ComposeJamo (Char -> JamoBuf
Hangul Char
ch))

{-# INLINE insertIntoRegBuf #-}
insertIntoRegBuf :: Char -> RegBuf -> RegBuf
insertIntoRegBuf :: Char -> RegBuf -> RegBuf
insertIntoRegBuf c :: Char
c (RegOne c0 :: Char
c0)
    | Char -> Int
CC.getCombiningClass Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
CC.getCombiningClass Char
c0
    = Char -> Char -> [Char] -> RegBuf
RegMany Char
c Char
c0 []
    | Bool
otherwise
    = Char -> Char -> [Char] -> RegBuf
RegMany Char
c0 Char
c []
insertIntoRegBuf c :: Char
c (RegMany c0 :: Char
c0 c1 :: Char
c1 cs :: [Char]
cs)
    | Int
cc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Char -> Int
CC.getCombiningClass 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
CC.getCombiningClass 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
CC.getCombiningClass Char
c
        (cs' :: [Char]
cs', 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
CC.getCombiningClass) [Char]
cs

{-# INLINE writeRegBuf #-}
writeRegBuf :: A.MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf :: MArray s -> Int -> RegBuf -> ST s Int
writeRegBuf arr :: MArray s
arr i :: Int
i = \case
    RegOne c :: Char
c -> do
        Int
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
        Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
    RegMany st :: Char
st c :: Char
c [] ->
        case Char -> Char -> Maybe Char
C.composePair Char
st Char
c of
            Just x :: Char
x -> do
                Int
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
                Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
            Nothing -> do
                Int
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
                Int
m <- MArray s -> Int -> Char -> ST s Int
forall s. MArray s -> Int -> Char -> ST s Int
unsafeWrite MArray s
arr (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n) Char
c
                Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)
    RegMany st0 :: Char
st0 c0 :: Char
c0 cs0 :: [Char]
cs0 -> [Char] -> Char -> [Char] -> ST s Int
go [] Char
st0 (Char
c0 Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs0)

    where

    -- arguments: uncombined chars, starter, unprocessed str
    go :: [Char] -> Char -> [Char] -> ST s Int
go uncs :: [Char]
uncs st :: 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 uncs :: [Char]
uncs st :: Char
st (c :: Char
c : cs :: [Char]
cs) = case Char -> Char -> Maybe Char
C.composePair Char
st Char
c of
        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 x :: Char
x  -> [Char] -> Char -> [Char] -> ST s Int
go [Char]
uncs Char
x [Char]
cs
        where
            cc :: Int
cc = Char -> Int
CC.getCombiningClass Char
c
            (same :: [Char]
same, bigger :: [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
CC.getCombiningClass) [Char]
cs

{-# INLINE flushComposeState #-}
flushComposeState :: A.MArray s -> Int -> ComposeState -> ST s Int
flushComposeState :: MArray s -> Int -> ComposeState -> ST s Int
flushComposeState arr :: MArray s
arr i :: Int
i = \case
    ComposeNone -> Int -> ST s Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
i
    ComposeReg rbuf :: 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 jbuf :: 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
    :: D.DecomposeMode
    -> A.MArray s       -- destination array for composition
    -> Char             -- input char
    -> Int              -- array index
    -> ComposeState
    -> ST s (Int, ComposeState)
composeChar :: DecomposeMode
-> MArray s
-> Char
-> Int
-> ComposeState
-> ST s (Int, ComposeState)
composeChar mode :: DecomposeMode
mode marr :: MArray s
marr = Char -> Int -> ComposeState -> ST s (Int, ComposeState)
go0

    where

    go0 :: Char -> Int -> ComposeState -> ST s (Int, ComposeState)
go0 ch :: Char
ch !Int
i !ComposeState
st =
        case ComposeState
st of
            ComposeReg rbuf :: RegBuf
rbuf
                | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
H.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
H.jamoLast -> do
                    Int
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
                    Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
ch Int
j
                | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
H.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
H.hangulLast -> do
                    Int
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
                    Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
ch Int
j
                | Bool
otherwise ->
                    RegBuf -> Char -> Int -> ComposeState -> ST s (Int, ComposeState)
composeReg RegBuf
rbuf Char
ch Int
i ComposeState
st
            ComposeJamo jbuf :: JamoBuf
jbuf
                | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
H.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
H.jamoLast -> 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
H.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
H.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
            ComposeNone
                | Int
ich Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
H.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
H.jamoLast ->
                    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
H.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
H.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 arr :: MArray s
arr i :: Int
i jbuf :: JamoBuf
jbuf ch :: Char
ch = do
        Int
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
        Char -> Int -> ST s (Int, ComposeState)
initReg Char
ch Int
j

    {-# INLINE initReg #-}
    initReg :: Char -> Int -> ST s (Int, ComposeState)
initReg !Char
ch !Int
i
        | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
ch =
            [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
D.decomposeChar DecomposeMode
mode Char
ch) Int
i ComposeState
ComposeNone
        | Bool
otherwise =
            (Int, ComposeState) -> ST s (Int, ComposeState)
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 rbuf :: RegBuf
rbuf !Char
ch !Int
i !ComposeState
st
        | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
ch =
            [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
D.decomposeChar DecomposeMode
mode Char
ch) Int
i ComposeState
st
        | Char -> Bool
CC.isCombining Char
ch = do
            (Int, ComposeState) -> ST s (Int, ComposeState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, RegBuf -> ComposeState
ComposeReg (Char -> RegBuf -> RegBuf
insertIntoRegBuf Char
ch RegBuf
rbuf))
        -- The first char in RegBuf may or may not be a starter. In
        -- case it is not we rely on composeStarterPair failing.
        | RegOne s :: Char
s <- RegBuf
rbuf
        , Char -> Bool
C.isSecondStarter Char
ch
        , Just x :: Char
x <- Char -> Char -> Maybe Char
C.composeStarterPair Char
s Char
ch =
            (Int, ComposeState) -> ST s (Int, ComposeState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
x)))
        | Bool
otherwise = do
            Int
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
            (Int, ComposeState) -> ST s (Int, ComposeState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
j, RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
ch))

    go :: [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [] !Int
i !ComposeState
st = (Int, ComposeState) -> ST s (Int, ComposeState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, ComposeState
st)
    go (ch :: Char
ch : rest :: [Char]
rest) i :: Int
i st :: ComposeState
st =
        case ComposeState
st of
            ComposeReg rbuf :: RegBuf
rbuf
                | Char -> Bool
H.isHangul Char
ch -> do
                    Int
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 :: Int
k, s :: ComposeState
s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
ch Int
j
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
k ComposeState
s
                | Char -> Bool
H.isJamo Char
ch -> do
                    Int
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 :: Int
k, s :: ComposeState
s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
ch Int
j
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
k ComposeState
s
                | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
ch ->
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
D.decomposeChar DecomposeMode
mode Char
ch [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest) Int
i ComposeState
st
                | Char -> Bool
CC.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 s :: Char
s <- RegBuf
rbuf
                , Char -> Bool
C.isSecondStarter Char
ch
                , Just x :: Char
x <- Char -> Char -> Maybe Char
C.composeStarterPair 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
                    Int
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
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j (RegBuf -> ComposeState
ComposeReg (Char -> RegBuf
RegOne Char
ch))
            ComposeJamo jbuf :: JamoBuf
jbuf
                | Char -> Bool
H.isJamo Char
ch -> do
                    (j :: Int
j, s :: ComposeState
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
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j ComposeState
s
                | Char -> Bool
H.isHangul Char
ch -> do
                    (j :: Int
j, s :: ComposeState
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
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j ComposeState
s
                | Bool
otherwise -> do
                    Int
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
D.isDecomposable DecomposeMode
mode Char
ch ->
                                [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
D.decomposeChar 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))
            ComposeNone
                | Char -> Bool
H.isHangul Char
ch -> do
                    (j :: Int
j, s :: ComposeState
s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initHangul Char
ch Int
i
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j ComposeState
s
                | Char -> Bool
H.isJamo Char
ch -> do
                    (j :: Int
j, s :: ComposeState
s) <- Char -> Int -> ST s (Int, ComposeState)
forall s. Char -> Int -> ST s (Int, ComposeState)
initJamo Char
ch Int
i
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go [Char]
rest Int
j ComposeState
s
                | DecomposeMode -> Char -> Bool
D.isDecomposable DecomposeMode
mode Char
ch ->
                    [Char] -> Int -> ComposeState -> ST s (Int, ComposeState)
go (DecomposeMode -> Char -> [Char]
D.decomposeChar 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))

-- | /O(n)/ Convert a 'Stream Char' into a composed normalized 'Text'.
unstreamC :: D.DecomposeMode -> Stream Char -> Text
unstreamC :: DecomposeMode -> Stream Char -> Text
unstreamC mode :: DecomposeMode
mode (Stream next0 :: s -> Step s Char
next0 s0 :: s
s0 len :: 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
$ \done :: MArray s -> Int -> ST s Text
done -> do
  -- Before encoding each char we perform a buffer realloc check assuming
  -- worst case encoding size of two 16-bit units for the char. Just add an
  -- extra space to the buffer so that we do not end up reallocating even when
  -- all the chars are encoded as single unit.
  let margin :: Int
margin = 1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
maxDecomposeLen
      mlen :: Int
mlen = (Int -> Size -> Int
upperBound 4 Size
len Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin)
  MArray s
arr0 <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
mlen
  let outer :: MArray s -> Int -> s -> Int -> ComposeState -> ST s Text
outer !MArray s
arr !Int
maxi = SPEC -> s -> Int -> ComposeState -> ST s Text
encode SPEC
SPEC
       where
        -- keep the common case loop as small as possible
        encode :: SPEC -> s -> Int -> ComposeState -> ST s Text
encode !SPEC
_ !s
si !Int
di st :: ComposeState
st =
            -- simply check for the worst case
            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
                    Done -> do
                        Int
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
                        MArray s -> Int -> ST s Text
done MArray s
arr Int
di'
                    Skip si' :: s
si'    -> SPEC -> s -> Int -> ComposeState -> ST s Text
encode SPEC
SPEC s
si' Int
di ComposeState
st
                    Yield c :: Char
c si' :: s
si' -> do
                        (di' :: Int
di', st' :: ComposeState
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
                        SPEC -> s -> Int -> ComposeState -> ST s Text
encode SPEC
SPEC s
si' Int
di' ComposeState
st'

        -- keep uncommon case separate from the common case code
        {-# NOINLINE realloc #-}
        realloc :: s -> Int -> ComposeState -> ST s Text
realloc !s
si !Int
di st :: ComposeState
st = do
            let newlen :: Int
newlen = Int
maxi Int -> Int -> Int
forall a. Num a => a -> a -> a
* 2
            MArray s
arr' <- Int -> ST s (MArray s)
forall s. Int -> ST s (MArray s)
A.new Int
newlen
            MArray s -> Int -> MArray s -> Int -> Int -> ST s ()
forall s. MArray s -> Int -> MArray s -> Int -> Int -> ST s ()
A.copyM MArray s
arr' 0 MArray s
arr 0 Int
di
            MArray s -> Int -> s -> Int -> ComposeState -> ST s Text
outer MArray s
arr' (Int
newlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) s
si Int
di ComposeState
st

  MArray s -> Int -> s -> Int -> ComposeState -> ST s Text
outer MArray s
arr0 (Int
mlen Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) s
s0 0 ComposeState
ComposeNone
{-# INLINE [0] unstreamC #-}