streamly-0.10.1: src/Streamly/Internal/Unicode/Char.hs
-- |
-- Module : Streamly.Internal.Unicode.Char
-- Copyright : (c) 2018 Composewell Technologies
--
-- License : BSD-3-Clause
-- Maintainer : streamly@composewell.com
-- Stability : experimental
-- Portability : GHC
-- XXX We are using head/tail at one place
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif
-- XXX This module should have the reader/writer unfold/refold and read/write
-- stream/fold routines to convert a char to/from stream.
--
module Streamly.Internal.Unicode.Char
(
-- * Predicates
isAsciiAlpha -- XXX Remove or move to unicode-data
-- XXX move to Unicode.Char.Case?
-- * Unicode aware operations
{-
toCaseFold
, toLower
, toUpper
, toTitle
-}
-- XXX Move to Unicode.Stream.Normalize or Unicode.Normalize?
-- * Unicode normalization
, NormalizationMode(..)
, normalize
)
where
#include "inline.hs"
import Data.Char (isAsciiUpper, isAsciiLower, chr, ord)
import Unicode.Char (DecomposeMode(..))
import Streamly.Internal.Data.Stream (Stream(..), Step (..))
import qualified Unicode.Char as Char
-------------------------------------------------------------------------------
-- Unicode aware operations on strings
-------------------------------------------------------------------------------
-- | Select alphabetic characters in the ascii character set.
--
-- /Pre-release/
--
{-# INLINE isAsciiAlpha #-}
isAsciiAlpha :: Char -> Bool
isAsciiAlpha c = isAsciiUpper c || isAsciiLower c
-------------------------------------------------------------------------------
-- Unicode aware operations on strings
-------------------------------------------------------------------------------
{-
-- |
-- /undefined/
toCaseFold :: IsStream t => Char -> t m Char
toCaseFold = undefined
-- |
-- /undefined/
toLower :: IsStream t => Char -> t m Char
toLower = undefined
-- |
-- /undefined/
toUpper :: IsStream t => Char -> t m Char
toUpper = undefined
-- |
-- /undefined/
toTitle :: IsStream t => Char -> t m Char
toTitle = undefined
-}
-------------------------------------------------------------------------------
-- Unicode normalization
-------------------------------------------------------------------------------
data NormalizationMode
= NFD -- ^ Canonical decomposition.
| NFKD -- ^ Compatibility decomposition.
| NFC -- ^ Canonical decomposition followed by canonical composition.
| NFKC -- ^ Compatibility decomposition followed by canonical composition.
deriving (Eq, Show, Enum)
-------------------------------------------------------------------------------
-- Normalization combinators
-------------------------------------------------------------------------------
type ReBuf = [Char]
{-# INLINE insertIntoReBuf #-}
insertIntoReBuf :: Char -> ReBuf -> ReBuf
insertIntoReBuf c [] = [c]
insertIntoReBuf c xxs@(x:xs)
| Char.combiningClass c < Char.combiningClass x = c : xxs
| otherwise = x : insertIntoReBuf c xs
-- {-# ANN type DecomposeState Fuse #-}
data DecomposeState st
= YieldCharList [Char] (DecomposeState st)
| ReadInputChar ReBuf st
| IsHangul Char st
| IsDecomposable [Char] ReBuf st
| DecomposeStop
{-# INLINE_NORMAL decomposeD #-}
decomposeD ::
Monad m => Bool -> DecomposeMode -> Stream m Char -> Stream m Char
decomposeD decomposeHangul mode (Stream step state) =
Stream sstep (ReadInputChar [] state)
where
{-# INLINE_LATE sstep #-}
-- XXX Does this cause any problem?
sstep _ (YieldCharList [] ns) = return $ Skip ns
sstep _ (YieldCharList (ch:chs) ns) =
return $ Yield ch (YieldCharList chs ns)
sstep gst (ReadInputChar rebuf st) = do
res <- step gst st
return
$ Skip
$ case res of
Yield ch st1
| Char.isHangul ch ->
if decomposeHangul
then YieldCharList rebuf (IsHangul ch st1)
else YieldCharList
(rebuf ++ [ch])
(ReadInputChar [] st1)
| Char.isDecomposable mode ch ->
IsDecomposable (Char.decompose mode ch) rebuf st1
| otherwise ->
if Char.isCombining ch
then ReadInputChar (insertIntoReBuf ch rebuf) st1
else YieldCharList
(rebuf ++ [ch])
(ReadInputChar [] st1)
Skip st1 -> ReadInputChar rebuf st1
Stop -> YieldCharList rebuf DecomposeStop
sstep _ (IsHangul ch st) =
return
$ Skip
$ let (l, v, t) = Char.decomposeHangul ch
in if t == chr Char.jamoTFirst
then YieldCharList [l, v] (ReadInputChar [] st)
else YieldCharList [l, v, t] (ReadInputChar [] st)
sstep _ (IsDecomposable [] rebuf st) =
return $ Skip $ ReadInputChar rebuf st
sstep _ (IsDecomposable (ch:chs) rebuf st)
| Char.isDecomposable mode ch =
return
$ Skip $ IsDecomposable (Char.decompose mode ch ++ chs) rebuf st
| otherwise =
return
$ Skip
$ if Char.isCombining ch
then IsDecomposable chs (insertIntoReBuf ch rebuf) st
else YieldCharList (rebuf ++ [ch]) (IsDecomposable chs [] st)
sstep _ DecomposeStop = return Stop
-- 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
{-# INLINE fromJamoBuf #-}
fromJamoBuf :: JamoBuf -> Char
fromJamoBuf (Jamo ch) = ch
fromJamoBuf (Hangul ch) = ch
fromJamoBuf (HangulLV ch) = ch
-- {-# ANN type ComposeState Fuse #-}
data ComposeState st
= YieldChar Char (ComposeState st)
| YieldList [Char] (ComposeState st)
| ComposeNone st
| ComposeReg Int [Char] st
| ComposeJamo JamoBuf st
| ComposeStop
-- Assumes every character except hangul characters are fully decomposed and the
-- combining characters are reordered. Hangul characters may or may not be
-- decomposed.
{-# INLINE_EARLY partialComposeD #-}
partialComposeD :: Monad m => Stream m Char -> Stream m Char
partialComposeD (Stream step state) = Stream step' (ComposeNone state)
where
{-# INLINE_NORMAL step' #-}
step' _ ComposeStop = return Stop
step' _ (YieldChar ch ns) = return $ Yield ch ns
step' _ (YieldList [] ns) = return $ Skip ns
step' _ (YieldList (x:xs) ns) = return $ Yield x $ YieldList xs ns
step' gst (ComposeNone st) = do
r <- step gst st
return
$ case r of
Yield x st1 -> Skip $ composeNone x st1
Skip st1 -> Skip $ ComposeNone st1
Stop -> Stop
step' gst (ComposeJamo jbuf st) = do
r <- step gst st
return
$ case r of
Yield x st1 -> Skip $ composeJamo jbuf x st1
Skip st1 -> Skip $ ComposeJamo jbuf st1
Stop -> Skip $ YieldChar (fromJamoBuf jbuf) ComposeStop
step' gst (ComposeReg i rbuf st) = do
r <- step gst st
return
$ case r of
Yield x st1 -> Skip $ composeReg i rbuf x st1
Skip st1 -> Skip $ ComposeReg i rbuf st1
Stop -> Skip $ YieldList rbuf ComposeStop
{-# INLINE initHangul #-}
initHangul c = ComposeJamo (Hangul c)
{-# INLINE initJamo #-}
initJamo c = ComposeJamo (Jamo c)
{-# INLINE initReg #-}
initReg !c = ComposeReg 0 [c]
{-# INLINE composeNone #-}
composeNone ch st
| Char.isHangul ch = initHangul ch st
| Char.isJamo ch = initJamo ch st
| otherwise = initReg ch st
{-# INLINE composeCharHangul #-}
composeCharHangul jbuf ch st =
YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Hangul ch) st
{-# INLINE composeCharJamo #-}
composeCharJamo jbuf ch st
| ich <= Char.jamoLLast =
YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Jamo ch) st
| ich < Char.jamoVFirst = flushAndWrite jbuf ch st
| ich <= Char.jamoVLast =
case jbuf of
Jamo c ->
case Char.jamoLIndex c of
Just li ->
let vi = ich - Char.jamoVFirst
lvi = li * Char.jamoNCount + vi * Char.jamoTCount
lv = chr (Char.hangulFirst + lvi)
in ComposeJamo (HangulLV lv) st
Nothing -> writeTwo c ch st
Hangul c -> writeTwo c ch st
HangulLV c -> writeTwo c ch st
| ich <= Char.jamoTFirst = flushAndWrite jbuf ch st
| otherwise = do
let ti = ich - Char.jamoTFirst
case jbuf of
Jamo c -> writeTwo c ch st
Hangul c
| Char.isHangulLV c -> writeLVT c ti st
| otherwise -> writeTwo c ch st
HangulLV c -> writeLVT c ti st
where
flushAndWrite jb c s = YieldList [fromJamoBuf jb, c] $ ComposeNone s
writeLVT lv ti s =
let lvt = chr $ ord lv + ti
in YieldChar lvt $ ComposeNone s
writeTwo c1 c2 s = YieldList [c1, c2] $ ComposeNone s
ich = ord ch
{-# INLINE composeJamo #-}
composeJamo jbuf ch st
| Char.isJamo ch = composeCharJamo jbuf ch st
| Char.isHangul ch = composeCharHangul jbuf ch st
| otherwise = YieldChar (fromJamoBuf jbuf) (ComposeReg 0 [ch] st)
-- i ~ Char.combiningClass (last rbuf)
{-# INLINE composeCharCombining #-}
composeCharCombining i rbuf ch st =
if cch > i
then case Char.compose str ch of
Nothing -> ComposeReg cch (rbuf ++ [ch]) st
Just x -> ComposeReg i (x : tail rbuf) st
else ComposeReg i (rbuf ++ [ch]) st
where
str = head rbuf
cch = Char.combiningClass ch
{-# INLINE composeReg #-}
composeReg i rbuf !ch !st
| Char.isHangul ch = YieldList rbuf $ initHangul ch st
| Char.isJamo ch = YieldList rbuf $ initJamo ch st
| Char.isCombining ch = composeCharCombining i rbuf ch st
| [s] <- rbuf
, Char.isCombiningStarter ch
, Just x <- Char.composeStarters s ch = ComposeReg 0 [x] st
| otherwise = YieldList rbuf $ ComposeReg 0 [ch] st
normalizeD :: Monad m => NormalizationMode -> Stream m Char -> Stream m Char
normalizeD NFD = decomposeD True Canonical
normalizeD NFKD = decomposeD True Kompat
normalizeD NFC = partialComposeD . decomposeD False Canonical
normalizeD NFKC = partialComposeD . decomposeD False Kompat
normalize ::
Monad m
=> NormalizationMode
-> Stream m Char
-> Stream m Char
normalize = normalizeD