git.iko.soy/streamly
on 6e021ce help sign in
streamly/src/Streamly/Internal/Unicode/Char.hs
317 lines 11 kB history raw
1-- |
2-- Module : Streamly.Internal.Unicode.Char
3-- Copyright : (c) 2018 Composewell Technologies
4--
5-- License : BSD-3-Clause
6-- Maintainer : streamly@composewell.com
7-- Stability : experimental
8-- Portability : GHC
9--
10module Streamly.Internal.Unicode.Char
11 (
12 -- * Predicates
13 isAsciiAlpha
15 -- * Unicode aware operations
16 {-
17 toCaseFold
18 , toLower
19 , toUpper
20 , toTitle
21 -}
23 -- * Unicode normalization
24 , NormalizationMode(..)
25 , normalize
26 )
27where
29#include "inline.hs"
31import Data.Char (isAsciiUpper, isAsciiLower, chr, ord)
32import Unicode.Char (DecomposeMode(..))
33import Streamly.Internal.Data.Stream.IsStream.Type
34 (IsStream, fromStreamD, toStreamD)
35import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
37import qualified Unicode.Char as Char
39-------------------------------------------------------------------------------
40-- Unicode aware operations on strings
41-------------------------------------------------------------------------------
43-- | Select alphabetic characters in the ascii character set.
44--
45-- /Pre-release/
46--
47{-# INLINE isAsciiAlpha #-}
48isAsciiAlpha :: Char -> Bool
49isAsciiAlpha c = isAsciiUpper c || isAsciiLower c
51-------------------------------------------------------------------------------
52-- Unicode aware operations on strings
53-------------------------------------------------------------------------------
55{-
56-- |
57-- /undefined/
58toCaseFold :: IsStream t => Char -> t m Char
59toCaseFold = undefined
61-- |
62-- /undefined/
63toLower :: IsStream t => Char -> t m Char
64toLower = undefined
66-- |
67-- /undefined/
68toUpper :: IsStream t => Char -> t m Char
69toUpper = undefined
71-- |
72-- /undefined/
73toTitle :: IsStream t => Char -> t m Char
74toTitle = undefined
75-}
77-------------------------------------------------------------------------------
78-- Unicode normalization
79-------------------------------------------------------------------------------
81data NormalizationMode
82 = NFD -- ^ Canonical decomposition.
83 | NFKD -- ^ Compatibility decomposition.
84 | NFC -- ^ Canonical decomposition followed by canonical composition.
85 | NFKC -- ^ Compatibility decomposition followed by canonical composition.
86 deriving (Eq, Show, Enum)
88-------------------------------------------------------------------------------
89-- Normalization combinators
90-------------------------------------------------------------------------------
92type ReBuf = [Char]
94{-# INLINE insertIntoReBuf #-}
95insertIntoReBuf :: Char -> ReBuf -> ReBuf
96insertIntoReBuf c [] = [c]
97insertIntoReBuf c xxs@(x:xs)
98 | Char.combiningClass c < Char.combiningClass x = c : xxs
99 | otherwise = x : insertIntoReBuf c xs
101-- {-# ANN type DecomposeState Fuse #-}
102data DecomposeState st
103 = YieldCharList [Char] (DecomposeState st)
104 | ReadInputChar ReBuf st
105 | IsHangul Char st
106 | IsDecomposable [Char] ReBuf st
107 | DecomposeStop
109{-# INLINE_NORMAL decomposeD #-}
110decomposeD ::
111 Monad m => Bool -> DecomposeMode -> Stream m Char -> Stream m Char
112decomposeD decomposeHangul mode (Stream step state) =
113 Stream sstep (ReadInputChar [] state)
115 where
117 {-# INLINE_LATE sstep #-}
118 -- XXX Does this cause any problem?
119 sstep _ (YieldCharList [] ns) = return $ Skip ns
120 sstep _ (YieldCharList (ch:chs) ns) =
121 return $ Yield ch (YieldCharList chs ns)
122 sstep gst (ReadInputChar rebuf st) = do
123 res <- step gst st
124 return
125 $ Skip
126 $ case res of
127 Yield ch st1
128 | Char.isHangul ch ->
129 if decomposeHangul
130 then YieldCharList rebuf (IsHangul ch st1)
131 else YieldCharList
132 (rebuf ++ [ch])
133 (ReadInputChar [] st1)
134 | Char.isDecomposable mode ch ->
135 IsDecomposable (Char.decompose mode ch) rebuf st1
136 | otherwise ->
137 if Char.isCombining ch
138 then ReadInputChar (insertIntoReBuf ch rebuf) st1
139 else YieldCharList
140 (rebuf ++ [ch])
141 (ReadInputChar [] st1)
142 Skip st1 -> ReadInputChar rebuf st1
143 Stop -> YieldCharList rebuf DecomposeStop
144 sstep _ (IsHangul ch st) =
145 return
146 $ Skip
147 $ let (l, v, t) = Char.decomposeHangul ch
148 in if t == chr Char.jamoTFirst
149 then YieldCharList [l, v] (ReadInputChar [] st)
150 else YieldCharList [l, v, t] (ReadInputChar [] st)
151 sstep _ (IsDecomposable [] rebuf st) =
152 return $ Skip $ ReadInputChar rebuf st
153 sstep _ (IsDecomposable (ch:chs) rebuf st)
154 | Char.isDecomposable mode ch =
155 return
156 $ Skip $ IsDecomposable (Char.decompose mode ch ++ chs) rebuf st
157 | otherwise =
158 return
159 $ Skip
160 $ if Char.isCombining ch
161 then IsDecomposable chs (insertIntoReBuf ch rebuf) st
162 else YieldCharList (rebuf ++ [ch]) (IsDecomposable chs [] st)
163 sstep _ DecomposeStop = return Stop
165-- Hold an L to wait for V, hold an LV to wait for T.
166data JamoBuf
167 = Jamo !Char -- Jamo L, V or T
168 | Hangul !Char -- Hangul Syllable LV or LVT
169 | HangulLV !Char
171{-# INLINE fromJamoBuf #-}
172fromJamoBuf :: JamoBuf -> Char
173fromJamoBuf (Jamo ch) = ch
174fromJamoBuf (Hangul ch) = ch
175fromJamoBuf (HangulLV ch) = ch
177-- {-# ANN type ComposeState Fuse #-}
178data ComposeState st
179 = YieldChar Char (ComposeState st)
180 | YieldList [Char] (ComposeState st)
181 | ComposeNone st
182 | ComposeReg Int [Char] st
183 | ComposeJamo JamoBuf st
184 | ComposeStop
186-- Assumes every character except hangul characters are fully decomposed and the
187-- combining characters are reordered. Hangul characters may or may not be
188-- decomposed.
189{-# INLINE_EARLY partialComposeD #-}
190partialComposeD :: Monad m => Stream m Char -> Stream m Char
191partialComposeD (Stream step state) = Stream step' (ComposeNone state)
193 where
195 {-# INLINE_NORMAL step' #-}
196 step' _ ComposeStop = return Stop
197 step' _ (YieldChar ch ns) = return $ Yield ch ns
198 step' _ (YieldList [] ns) = return $ Skip ns
199 step' _ (YieldList (x:xs) ns) = return $ Yield x $ YieldList xs ns
200 step' gst (ComposeNone st) = do
201 r <- step gst st
202 return
203 $ case r of
204 Yield x st1 -> Skip $ composeNone x st1
205 Skip st1 -> Skip $ ComposeNone st1
206 Stop -> Stop
207 step' gst (ComposeJamo jbuf st) = do
208 r <- step gst st
209 return
210 $ case r of
211 Yield x st1 -> Skip $ composeJamo jbuf x st1
212 Skip st1 -> Skip $ ComposeJamo jbuf st1
213 Stop -> Skip $ YieldChar (fromJamoBuf jbuf) ComposeStop
214 step' gst (ComposeReg i rbuf st) = do
215 r <- step gst st
216 return
217 $ case r of
218 Yield x st1 -> Skip $ composeReg i rbuf x st1
219 Skip st1 -> Skip $ ComposeReg i rbuf st1
220 Stop -> Skip $ YieldList rbuf ComposeStop
222 {-# INLINE initHangul #-}
223 initHangul c st = ComposeJamo (Hangul c) st
225 {-# INLINE initJamo #-}
226 initJamo c st = ComposeJamo (Jamo c) st
228 {-# INLINE initReg #-}
229 initReg !c st = ComposeReg 0 [c] st
231 {-# INLINE composeNone #-}
232 composeNone ch st
233 | Char.isHangul ch = initHangul ch st
234 | Char.isJamo ch = initJamo ch st
235 | otherwise = initReg ch st
237 {-# INLINE composeCharHangul #-}
238 composeCharHangul jbuf ch st =
239 YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Hangul ch) st
241 {-# INLINE composeCharJamo #-}
242 composeCharJamo jbuf ch st
243 | ich <= Char.jamoLLast =
244 YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Jamo ch) st
245 | ich < Char.jamoVFirst = flushAndWrite jbuf ch st
246 | ich <= Char.jamoVLast =
247 case jbuf of
248 Jamo c ->
249 case Char.jamoLIndex c of
250 Just li ->
251 let vi = ich - Char.jamoVFirst
252 lvi = li * Char.jamoNCount + vi * Char.jamoTCount
253 lv = chr (Char.hangulFirst + lvi)
254 in ComposeJamo (HangulLV lv) st
255 Nothing -> writeTwo c ch st
256 Hangul c -> writeTwo c ch st
257 HangulLV c -> writeTwo c ch st
258 | ich <= Char.jamoTFirst = flushAndWrite jbuf ch st
259 | otherwise = do
260 let ti = ich - Char.jamoTFirst
261 case jbuf of
262 Jamo c -> writeTwo c ch st
263 Hangul c
264 | Char.isHangulLV c -> writeLVT c ti st
265 | otherwise -> writeTwo c ch st
266 HangulLV c -> writeLVT c ti st
268 where
270 flushAndWrite jb c s = YieldList [fromJamoBuf jb, c] $ ComposeNone s
272 writeLVT lv ti s =
273 let lvt = chr $ ord lv + ti
274 in YieldChar lvt $ ComposeNone s
276 writeTwo c1 c2 s = YieldList [c1, c2] $ ComposeNone s
278 ich = ord ch
280 {-# INLINE composeJamo #-}
281 composeJamo jbuf ch st
282 | Char.isJamo ch = composeCharJamo jbuf ch st
283 | Char.isHangul ch = composeCharHangul jbuf ch st
284 | otherwise = YieldChar (fromJamoBuf jbuf) (ComposeReg 0 [ch] st)
286 -- i ~ Char.combiningClass (last rbuf)
287 {-# INLINE composeCharCombining #-}
288 composeCharCombining i rbuf ch st =
289 if cch > i
290 then case Char.compose str ch of
291 Nothing -> ComposeReg cch (rbuf ++ [ch]) st
292 Just x -> ComposeReg i (x : tail rbuf) st
293 else ComposeReg i (rbuf ++ [ch]) st
295 where
297 str = head rbuf
298 cch = Char.combiningClass ch
300 {-# INLINE composeReg #-}
301 composeReg i rbuf !ch !st
302 | Char.isHangul ch = YieldList rbuf $ initHangul ch st
303 | Char.isJamo ch = YieldList rbuf $ initJamo ch st
304 | Char.isCombining ch = composeCharCombining i rbuf ch st
305 | [s] <- rbuf
306 , Char.isCombiningStarter ch
307 , Just x <- Char.composeStarters s ch = ComposeReg 0 [x] st
308 | otherwise = YieldList rbuf $ ComposeReg 0 [ch] st
310normalizeD :: Monad m => NormalizationMode -> Stream m Char -> Stream m Char
311normalizeD NFD = decomposeD True Canonical
312normalizeD NFKD = decomposeD True Kompat
313normalizeD NFC = partialComposeD . decomposeD False Canonical
314normalizeD NFKC = partialComposeD . decomposeD False Kompat
316normalize :: (IsStream t, Monad m) => NormalizationMode -> t m Char -> t m Char
317normalize mode = fromStreamD . normalizeD mode . toStreamD