git.iko.soy/streamly
on 70fbefe help sign in
streamly/src/Streamly/Internal/Unicode/Char.hs
319 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 Data.Typeable (Typeable)
34import Unicode.Char (DecomposeMode(..))
35import Streamly.Internal.Data.Stream.IsStream.Type
36 (IsStream, fromStreamD, toStreamD)
37import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
39import qualified Unicode.Char as Char
41-------------------------------------------------------------------------------
42-- Unicode aware operations on strings
43-------------------------------------------------------------------------------
45-- | Select alphabetic characters in the ascii character set.
46--
47-- /Pre-release/
48--
49{-# INLINE isAsciiAlpha #-}
50isAsciiAlpha :: Char -> Bool
51isAsciiAlpha c = isAsciiUpper c || isAsciiLower c
53-------------------------------------------------------------------------------
54-- Unicode aware operations on strings
55-------------------------------------------------------------------------------
57{-
58-- |
59-- /undefined/
60toCaseFold :: IsStream t => Char -> t m Char
61toCaseFold = undefined
63-- |
64-- /undefined/
65toLower :: IsStream t => Char -> t m Char
66toLower = undefined
68-- |
69-- /undefined/
70toUpper :: IsStream t => Char -> t m Char
71toUpper = undefined
73-- |
74-- /undefined/
75toTitle :: IsStream t => Char -> t m Char
76toTitle = undefined
77-}
79-------------------------------------------------------------------------------
80-- Unicode normalization
81-------------------------------------------------------------------------------
83data NormalizationMode
84 = NFD -- ^ Canonical decomposition.
85 | NFKD -- ^ Compatibility decomposition.
86 | NFC -- ^ Canonical decomposition followed by canonical composition.
87 | NFKC -- ^ Compatibility decomposition followed by canonical composition.
88 deriving (Eq, Show, Enum, Typeable)
90-------------------------------------------------------------------------------
91-- Normalization combinators
92-------------------------------------------------------------------------------
94type ReBuf = [Char]
96{-# INLINE insertIntoReBuf #-}
97insertIntoReBuf :: Char -> ReBuf -> ReBuf
98insertIntoReBuf c [] = [c]
99insertIntoReBuf c xxs@(x:xs)
100 | Char.combiningClass c < Char.combiningClass x = c : xxs
101 | otherwise = x : insertIntoReBuf c xs
103-- {-# ANN type DecomposeState Fuse #-}
104data DecomposeState st
105 = YieldCharList [Char] (DecomposeState st)
106 | ReadInputChar ReBuf st
107 | IsHangul Char st
108 | IsDecomposable [Char] ReBuf st
109 | DecomposeStop
111{-# INLINE_NORMAL decomposeD #-}
112decomposeD ::
113 Monad m => Bool -> DecomposeMode -> Stream m Char -> Stream m Char
114decomposeD decomposeHangul mode (Stream step state) =
115 Stream sstep (ReadInputChar [] state)
117 where
119 {-# INLINE_LATE sstep #-}
120 -- XXX Does this cause any problem?
121 sstep _ (YieldCharList [] ns) = return $ Skip ns
122 sstep _ (YieldCharList (ch:chs) ns) =
123 return $ Yield ch (YieldCharList chs ns)
124 sstep gst (ReadInputChar rebuf st) = do
125 res <- step gst st
126 return
127 $ Skip
128 $ case res of
129 Yield ch st1
130 | Char.isHangul ch ->
131 if decomposeHangul
132 then YieldCharList rebuf (IsHangul ch st1)
133 else YieldCharList
134 (rebuf ++ [ch])
135 (ReadInputChar [] st1)
136 | Char.isDecomposable mode ch ->
137 IsDecomposable (Char.decompose mode ch) rebuf st1
138 | otherwise ->
139 if Char.isCombining ch
140 then ReadInputChar (insertIntoReBuf ch rebuf) st1
141 else YieldCharList
142 (rebuf ++ [ch])
143 (ReadInputChar [] st1)
144 Skip st1 -> ReadInputChar rebuf st1
145 Stop -> YieldCharList rebuf DecomposeStop
146 sstep _ (IsHangul ch st) =
147 return
148 $ Skip
149 $ let (l, v, t) = Char.decomposeHangul ch
150 in if t == chr Char.jamoTFirst
151 then YieldCharList [l, v] (ReadInputChar [] st)
152 else YieldCharList [l, v, t] (ReadInputChar [] st)
153 sstep _ (IsDecomposable [] rebuf st) =
154 return $ Skip $ ReadInputChar rebuf st
155 sstep _ (IsDecomposable (ch:chs) rebuf st)
156 | Char.isDecomposable mode ch =
157 return
158 $ Skip $ IsDecomposable (Char.decompose mode ch ++ chs) rebuf st
159 | otherwise =
160 return
161 $ Skip
162 $ if Char.isCombining ch
163 then IsDecomposable chs (insertIntoReBuf ch rebuf) st
164 else YieldCharList (rebuf ++ [ch]) (IsDecomposable chs [] st)
165 sstep _ DecomposeStop = return Stop
167-- Hold an L to wait for V, hold an LV to wait for T.
168data JamoBuf
169 = Jamo !Char -- Jamo L, V or T
170 | Hangul !Char -- Hangul Syllable LV or LVT
171 | HangulLV !Char
173{-# INLINE fromJamoBuf #-}
174fromJamoBuf :: JamoBuf -> Char
175fromJamoBuf (Jamo ch) = ch
176fromJamoBuf (Hangul ch) = ch
177fromJamoBuf (HangulLV ch) = ch
179-- {-# ANN type ComposeState Fuse #-}
180data ComposeState st
181 = YieldChar Char (ComposeState st)
182 | YieldList [Char] (ComposeState st)
183 | ComposeNone st
184 | ComposeReg Int [Char] st
185 | ComposeJamo JamoBuf st
186 | ComposeStop
188-- Assumes every character except hangul characters are fully decomposed and the
189-- combining characters are reordered. Hangul characters may or may not be
190-- decomposed.
191{-# INLINE_EARLY partialComposeD #-}
192partialComposeD :: Monad m => Stream m Char -> Stream m Char
193partialComposeD (Stream step state) = Stream step' (ComposeNone state)
195 where
197 {-# INLINE_NORMAL step' #-}
198 step' _ ComposeStop = return Stop
199 step' _ (YieldChar ch ns) = return $ Yield ch ns
200 step' _ (YieldList [] ns) = return $ Skip ns
201 step' _ (YieldList (x:xs) ns) = return $ Yield x $ YieldList xs ns
202 step' gst (ComposeNone st) = do
203 r <- step gst st
204 return
205 $ case r of
206 Yield x st1 -> Skip $ composeNone x st1
207 Skip st1 -> Skip $ ComposeNone st1
208 Stop -> Stop
209 step' gst (ComposeJamo jbuf st) = do
210 r <- step gst st
211 return
212 $ case r of
213 Yield x st1 -> Skip $ composeJamo jbuf x st1
214 Skip st1 -> Skip $ ComposeJamo jbuf st1
215 Stop -> Skip $ YieldChar (fromJamoBuf jbuf) ComposeStop
216 step' gst (ComposeReg i rbuf st) = do
217 r <- step gst st
218 return
219 $ case r of
220 Yield x st1 -> Skip $ composeReg i rbuf x st1
221 Skip st1 -> Skip $ ComposeReg i rbuf st1
222 Stop -> Skip $ YieldList rbuf ComposeStop
224 {-# INLINE initHangul #-}
225 initHangul c st = ComposeJamo (Hangul c) st
227 {-# INLINE initJamo #-}
228 initJamo c st = ComposeJamo (Jamo c) st
230 {-# INLINE initReg #-}
231 initReg !c st = ComposeReg 0 [c] st
233 {-# INLINE composeNone #-}
234 composeNone ch st
235 | Char.isHangul ch = initHangul ch st
236 | Char.isJamo ch = initJamo ch st
237 | otherwise = initReg ch st
239 {-# INLINE composeCharHangul #-}
240 composeCharHangul jbuf ch st =
241 YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Hangul ch) st
243 {-# INLINE composeCharJamo #-}
244 composeCharJamo jbuf ch st
245 | ich <= Char.jamoLLast =
246 YieldChar (fromJamoBuf jbuf) $ ComposeJamo (Jamo ch) st
247 | ich < Char.jamoVFirst = flushAndWrite jbuf ch st
248 | ich <= Char.jamoVLast =
249 case jbuf of
250 Jamo c ->
251 case Char.jamoLIndex c of
252 Just li ->
253 let vi = ich - Char.jamoVFirst
254 lvi = li * Char.jamoNCount + vi * Char.jamoTCount
255 lv = chr (Char.hangulFirst + lvi)
256 in ComposeJamo (HangulLV lv) st
257 Nothing -> writeTwo c ch st
258 Hangul c -> writeTwo c ch st
259 HangulLV c -> writeTwo c ch st
260 | ich <= Char.jamoTFirst = flushAndWrite jbuf ch st
261 | otherwise = do
262 let ti = ich - Char.jamoTFirst
263 case jbuf of
264 Jamo c -> writeTwo c ch st
265 Hangul c
266 | Char.isHangulLV c -> writeLVT c ti st
267 | otherwise -> writeTwo c ch st
268 HangulLV c -> writeLVT c ti st
270 where
272 flushAndWrite jb c s = YieldList [fromJamoBuf jb, c] $ ComposeNone s
274 writeLVT lv ti s =
275 let lvt = chr $ ord lv + ti
276 in YieldChar lvt $ ComposeNone s
278 writeTwo c1 c2 s = YieldList [c1, c2] $ ComposeNone s
280 ich = ord ch
282 {-# INLINE composeJamo #-}
283 composeJamo jbuf ch st
284 | Char.isJamo ch = composeCharJamo jbuf ch st
285 | Char.isHangul ch = composeCharHangul jbuf ch st
286 | otherwise = YieldChar (fromJamoBuf jbuf) (ComposeReg 0 [ch] st)
288 -- i ~ Char.combiningClass (last rbuf)
289 {-# INLINE composeCharCombining #-}
290 composeCharCombining i rbuf ch st =
291 if cch > i
292 then case Char.compose str ch of
293 Nothing -> ComposeReg cch (rbuf ++ [ch]) st
294 Just x -> ComposeReg i (x : tail rbuf) st
295 else ComposeReg i (rbuf ++ [ch]) st
297 where
299 str = head rbuf
300 cch = Char.combiningClass ch
302 {-# INLINE composeReg #-}
303 composeReg i rbuf !ch !st
304 | Char.isHangul ch = YieldList rbuf $ initHangul ch st
305 | Char.isJamo ch = YieldList rbuf $ initJamo ch st
306 | Char.isCombining ch = composeCharCombining i rbuf ch st
307 | [s] <- rbuf
308 , Char.isCombiningStarter ch
309 , Just x <- Char.composeStarters s ch = ComposeReg 0 [x] st
310 | otherwise = YieldList rbuf $ ComposeReg 0 [ch] st
312normalizeD :: Monad m => NormalizationMode -> Stream m Char -> Stream m Char
313normalizeD NFD = decomposeD True Canonical
314normalizeD NFKD = decomposeD True Kompat
315normalizeD NFC = partialComposeD . decomposeD False Canonical
316normalizeD NFKC = partialComposeD . decomposeD False Kompat
318normalize :: (IsStream t, Monad m) => NormalizationMode -> t m Char -> t m Char
319normalize mode = fromStreamD . normalizeD mode . toStreamD