git.iko.soy/streamly
on c3dcabc help sign in
streamly/src/Streamly/Internal/Data/Unicode/Stream.hs
792 lines 30 kB history raw
1-- |
2-- Module : Streamly.Data.Internal.Unicode.Stream
3-- Copyright : (c) 2018 Composewell Technologies
4-- (c) Bjoern Hoehrmann 2008-2009
5--
6-- License : BSD3
7-- Maintainer : streamly@composewell.com
8-- Stability : experimental
9-- Portability : GHC
10--
12#include "inline.hs"
14module Streamly.Internal.Data.Unicode.Stream
15 (
16 -- * Construction (Decoding)
17 decodeLatin1
18 , decodeUtf8
19 , decodeUtf8Lax
20 , DecodeError(..)
21 , DecodeState
22 , CodePoint
23 , decodeUtf8Either
24 , resumeDecodeUtf8Either
25 , decodeUtf8Arrays
26 , decodeUtf8ArraysLenient
28 -- * Elimination (Encoding)
29 , encodeLatin1
30 , encodeLatin1Lax
31 , encodeUtf8
32 , encodeUtf8Lax
33 {-
34 -- * Operations on character strings
35 , strip -- (dropAround isSpace)
36 , stripEnd
37 -}
39 -- * StreamD UTF8 Encoding / Decoding transformations.
40 , decodeUtf8D
41 , encodeUtf8D
42 , decodeUtf8LenientD
43 , decodeUtf8EitherD
44 , resumeDecodeUtf8EitherD
45 , decodeUtf8ArraysD
46 , decodeUtf8ArraysLenientD
48 -- * Transformation
49 , stripStart
50 , lines
51 , words
52 , unlines
53 , unwords
54 )
55where
57import Control.Monad.IO.Class (MonadIO, liftIO)
58import Data.Bits (shiftR, shiftL, (.|.), (.&.))
59import Data.Char (ord)
60import Data.Word (Word8)
61import Foreign.ForeignPtr (touchForeignPtr)
62import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
63import Foreign.Storable (Storable(..))
64import GHC.Base (assert, unsafeChr)
65import GHC.ForeignPtr (ForeignPtr (..))
66import GHC.IO.Encoding.Failure (isSurrogate)
67import GHC.Ptr (Ptr (..), plusPtr)
68import System.IO.Unsafe (unsafePerformIO)
69import Streamly (IsStream)
70import Streamly.Data.Fold (Fold)
71import Streamly.Memory.Array (Array)
72import Streamly.Internal.Data.Unfold (Unfold)
73import Streamly.Internal.Data.SVar (adaptState)
74import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
75import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))
77import qualified Streamly.Internal.Memory.Array.Types as A
78import qualified Streamly.Internal.Data.Stream.IsStream as S
79import qualified Streamly.Internal.Data.Stream.StreamD as D
81import Prelude hiding (String, lines, words, unlines, unwords)
83-------------------------------------------------------------------------------
84-- Encoding/Decoding Unicode (UTF-8) Characters
85-------------------------------------------------------------------------------
87-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
89data WList = WCons !Word8 !WList | WNil
91{-# INLINE ord2 #-}
92ord2 :: Char -> WList
93ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
94 where
95 n = ord c
96 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
97 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
99{-# INLINE ord3 #-}
100ord3 :: Char -> WList
101ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
102 where
103 n = ord c
104 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
105 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
106 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
108{-# INLINE ord4 #-}
109ord4 :: Char -> WList
110ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
111 where
112 n = ord c
113 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
114 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
115 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
116 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
118data CodingFailureMode
119 = TransliterateCodingFailure
120 | ErrorOnCodingFailure
121 deriving (Show)
123{-# INLINE replacementChar #-}
124replacementChar :: Char
125replacementChar = '\xFFFD'
127-- Int helps in cheaper conversion from Int to Char
128type CodePoint = Int
129type DecodeState = Word8
131-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
133-- XXX Use names decodeSuccess = 0, decodeFailure = 12
135decodeTable :: [Word8]
136decodeTable = [
137 -- The first part of the table maps bytes to character classes that
138 -- to reduce the size of the transition table and create bitmasks.
139 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
140 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
141 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
142 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
143 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,
144 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
145 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
146 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,
148 -- The second part is a transition table that maps a combination
149 -- of a state of the automaton and a character class to a state.
150 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
151 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
152 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
153 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
154 12,36,12,12,12,12,12,12,12,12,12,12
155 ]
157{-# NOINLINE utf8d #-}
158utf8d :: A.Array Word8
159utf8d =
160 unsafePerformIO
161 -- Aligning to cacheline makes a barely noticeable difference
162 -- XXX currently alignment is not implemented for unmanaged allocation
163 $ D.runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))
164 (D.fromList decodeTable)
166-- | Return element at the specified index without checking the bounds.
167-- and without touching the foreign ptr.
168{-# INLINE_NORMAL unsafePeekElemOff #-}
169unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
170unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
172-- decode is split into two separate cases to avoid branching instructions.
173-- From the higher level flow we already know which case we are in so we can
174-- call the appropriate decode function.
175--
176-- When the state is 0
177{-# INLINE decode0 #-}
178decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
179decode0 table byte =
180 let !t = table `unsafePeekElemOff` fromIntegral byte
181 !codep' = (0xff `shiftR` fromIntegral t) .&. fromIntegral byte
182 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
183 in assert ((byte > 0x7f || error showByte)
184 && (state' /= 0 || error (showByte ++ showTable)))
185 (Tuple' state' codep')
187 where
189 utf8table =
190 let !(Ptr addr) = table
191 end = table `plusPtr` 364
192 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
193 showByte = "Streamly: decode0: byte: " ++ show byte
194 showTable = " table: " ++ show utf8table
196-- When the state is not 0
197{-# INLINE decode1 #-}
198decode1
199 :: Ptr Word8
200 -> DecodeState
201 -> CodePoint
202 -> Word8
203 -> Tuple' DecodeState CodePoint
204decode1 table state codep byte =
205 -- Remember codep is Int type!
206 -- Can it be unsafe to convert the resulting Int to Char?
207 let !t = table `unsafePeekElemOff` fromIntegral byte
208 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
209 !state' = table `unsafePeekElemOff`
210 (256 + fromIntegral state + fromIntegral t)
211 in assert (codep' <= 0x10FFFF
212 || error (showByte ++ showState state codep))
213 (Tuple' state' codep')
214 where
216 utf8table =
217 let !(Ptr addr) = table
218 end = table `plusPtr` 364
219 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
220 showByte = "Streamly: decode1: byte: " ++ show byte
221 showState st cp =
222 " state: " ++ show st ++
223 " codepoint: " ++ show cp ++
224 " table: " ++ show utf8table
226-- We can divide the errors in three general categories:
227-- * A non-starter was encountered in a begin state
228-- * A starter was encountered without completing a codepoint
229-- * The last codepoint was not complete (input underflow)
230--
231-- Need to separate resumable and non-resumable error. In case of non-resumable
232-- error we can also provide the failing byte. In case of resumable error the
233-- state can be opaque.
234--
235data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
237data FreshPoint s a
238 = FreshPointDecodeInit s
239 | FreshPointDecodeInit1 s Word8
240 | FreshPointDecodeFirst s Word8
241 | FreshPointDecoding s !DecodeState !CodePoint
242 | YieldAndContinue a (FreshPoint s a)
243 | Done
245-- XXX write it as a parser and use parseMany to decode a stream, need to check
246-- if that preserves the same performance. Or we can use a resumable parser
247-- that parses a chunk at a time.
248--
249-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that
250-- decodeUtf8Either preserves the performance characterstics.
251--
252{-# INLINE_NORMAL decodeUtf8WithD #-}
253decodeUtf8WithD :: Monad m
254 => CodingFailureMode -> Stream m Word8 -> Stream m Char
255decodeUtf8WithD cfm (Stream step state) =
256 let A.Array p _ = utf8d
257 !ptr = unsafeForeignPtrToPtr p
258 in Stream (step' ptr) (FreshPointDecodeInit state)
260 where
262 prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: "
264 {-# INLINE handleError #-}
265 handleError e s =
266 case cfm of
267 ErrorOnCodingFailure -> error e
268 TransliterateCodingFailure -> YieldAndContinue replacementChar s
270 {-# INLINE handleUnderflow #-}
271 handleUnderflow =
272 case cfm of
273 ErrorOnCodingFailure -> error $ prefix ++ "Not enough input"
274 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
276 {-# INLINE_LATE step' #-}
277 step' _ gst (FreshPointDecodeInit st) = do
278 r <- step (adaptState gst) st
279 return $ case r of
280 Yield x s -> Skip (FreshPointDecodeInit1 s x)
281 Skip s -> Skip (FreshPointDecodeInit s)
282 Stop -> Skip Done
284 step' _ _ (FreshPointDecodeInit1 st x) = do
285 -- Note: It is important to use a ">" instead of a "<=" test
286 -- here for GHC to generate code layout for default branch
287 -- prediction for the common case. This is fragile and might
288 -- change with the compiler versions, we need a more reliable
289 -- "likely" primitive to control branch predication.
290 case x > 0x7f of
291 False ->
292 return $ Skip $ YieldAndContinue
293 (unsafeChr (fromIntegral x))
294 (FreshPointDecodeInit st)
295 -- Using a separate state here generates a jump to a
296 -- separate code block in the core which seems to perform
297 -- slightly better for the non-ascii case.
298 True -> return $ Skip $ FreshPointDecodeFirst st x
300 -- XXX should we merge it with FreshPointDecodeInit1?
301 step' table _ (FreshPointDecodeFirst st x) = do
302 let (Tuple' sv cp) = decode0 table x
303 return $
304 case sv of
305 12 ->
306 let msg = prefix ++ "Invalid first UTF8 byte " ++ show x
307 in Skip $ handleError msg (FreshPointDecodeInit st)
308 0 -> error "unreachable state"
309 _ -> Skip (FreshPointDecoding st sv cp)
311 -- We recover by trying the new byte x as a starter of a new codepoint.
312 -- XXX need to use the same recovery in array decoding routine as well
313 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
314 r <- step (adaptState gst) st
315 case r of
316 Yield x s -> do
317 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
318 return $ case sv of
319 0 -> Skip $ YieldAndContinue
320 (unsafeChr cp) (FreshPointDecodeInit s)
321 12 ->
322 let msg = prefix
323 ++ "Invalid subsequent UTF8 byte "
324 ++ show x
325 ++ " in state "
326 ++ show statePtr
327 ++ " accumulated value "
328 ++ show codepointPtr
329 in Skip $ handleError msg (FreshPointDecodeInit1 s x)
330 _ -> Skip (FreshPointDecoding s sv cp)
331 Skip s -> return $
332 Skip (FreshPointDecoding s statePtr codepointPtr)
333 Stop -> return $ Skip handleUnderflow
335 step' _ _ (YieldAndContinue c s) = return $ Yield c s
336 step' _ _ Done = return Stop
338{-# INLINE decodeUtf8D #-}
339decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char
340decodeUtf8D = decodeUtf8WithD ErrorOnCodingFailure
342{-# INLINE decodeUtf8LenientD #-}
343decodeUtf8LenientD :: Monad m => Stream m Word8 -> Stream m Char
344decodeUtf8LenientD = decodeUtf8WithD TransliterateCodingFailure
346{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}
347resumeDecodeUtf8EitherD
348 :: Monad m
349 => DecodeState
350 -> CodePoint
351 -> Stream m Word8
352 -> Stream m (Either DecodeError Char)
353resumeDecodeUtf8EitherD dst codep (Stream step state) =
354 let A.Array p _ = utf8d
355 !ptr = unsafeForeignPtrToPtr p
356 stt =
357 if dst == 0
358 then FreshPointDecodeInit state
359 else FreshPointDecoding state dst codep
360 in Stream (step' ptr) stt
361 where
362 {-# INLINE_LATE step' #-}
363 step' _ gst (FreshPointDecodeInit st) = do
364 r <- step (adaptState gst) st
365 return $ case r of
366 Yield x s -> Skip (FreshPointDecodeInit1 s x)
367 Skip s -> Skip (FreshPointDecodeInit s)
368 Stop -> Skip Done
370 step' _ _ (FreshPointDecodeInit1 st x) = do
371 -- Note: It is important to use a ">" instead of a "<=" test
372 -- here for GHC to generate code layout for default branch
373 -- prediction for the common case. This is fragile and might
374 -- change with the compiler versions, we need a more reliable
375 -- "likely" primitive to control branch predication.
376 case x > 0x7f of
377 False ->
378 return $ Skip $ YieldAndContinue
379 (Right $ unsafeChr (fromIntegral x))
380 (FreshPointDecodeInit st)
381 -- Using a separate state here generates a jump to a
382 -- separate code block in the core which seems to perform
383 -- slightly better for the non-ascii case.
384 True -> return $ Skip $ FreshPointDecodeFirst st x
386 -- XXX should we merge it with FreshPointDecodeInit1?
387 step' table _ (FreshPointDecodeFirst st x) = do
388 let (Tuple' sv cp) = decode0 table x
389 return $
390 case sv of
391 12 ->
392 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
393 (FreshPointDecodeInit st)
394 0 -> error "unreachable state"
395 _ -> Skip (FreshPointDecoding st sv cp)
397 -- We recover by trying the new byte x a starter of a new codepoint.
398 -- XXX on error need to report the next byte "x" as well.
399 -- XXX need to use the same recovery in array decoding routine as well
400 step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
401 r <- step (adaptState gst) st
402 case r of
403 Yield x s -> do
404 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
405 return $
406 case sv of
407 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
408 (FreshPointDecodeInit s)
409 12 ->
410 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
411 (FreshPointDecodeInit1 s x)
412 _ -> Skip (FreshPointDecoding s sv cp)
413 Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
414 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
416 step' _ _ (YieldAndContinue c s) = return $ Yield c s
417 step' _ _ Done = return Stop
419{-# INLINE_NORMAL decodeUtf8EitherD #-}
420decodeUtf8EitherD :: Monad m
421 => Stream m Word8 -> Stream m (Either DecodeError Char)
422decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0
424data FlattenState s a
425 = OuterLoop s !(Maybe (DecodeState, CodePoint))
426 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
427 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
428 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
429 !DecodeState !CodePoint
430 | YAndC !Char (FlattenState s a) -- These constructors can be
431 -- encoded in the FreshPoint
432 -- type, I prefer to keep these
433 -- flat even though that means
434 -- coming up with new names
435 | D
437-- The normal decodeUtf8 above should fuse with flattenArrays
438-- to create this exact code but it doesn't for some reason, as of now this
439-- remains the fastest way I could figure out to decodeUtf8.
440--
441-- XXX Add Proper error messages
442{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
443decodeUtf8ArraysWithD ::
444 MonadIO m
445 => CodingFailureMode
446 -> Stream m (A.Array Word8)
447 -> Stream m Char
448decodeUtf8ArraysWithD cfm (Stream step state) =
449 let A.Array p _ = utf8d
450 !ptr = unsafeForeignPtrToPtr p
451 in Stream (step' ptr) (OuterLoop state Nothing)
452 where
453 {-# INLINE transliterateOrError #-}
454 transliterateOrError e s =
455 case cfm of
456 ErrorOnCodingFailure -> error e
457 TransliterateCodingFailure -> YAndC replacementChar s
458 {-# INLINE inputUnderflow #-}
459 inputUnderflow =
460 case cfm of
461 ErrorOnCodingFailure ->
462 error
463 "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Input Underflow"
464 TransliterateCodingFailure -> YAndC replacementChar D
465 {-# INLINE_LATE step' #-}
466 step' _ gst (OuterLoop st Nothing) = do
467 r <- step (adaptState gst) st
468 return $
469 case r of
470 Yield A.Array {..} s ->
471 let p = unsafeForeignPtrToPtr aStart
472 in Skip (InnerLoopDecodeInit s aStart p aEnd)
473 Skip s -> Skip (OuterLoop s Nothing)
474 Stop -> Skip D
475 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
476 r <- step (adaptState gst) st
477 return $
478 case r of
479 Yield A.Array {..} s ->
480 let p = unsafeForeignPtrToPtr aStart
481 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
482 Skip s -> Skip (OuterLoop s dst)
483 Stop -> Skip inputUnderflow
484 step' _ _ (InnerLoopDecodeInit st startf p end)
485 | p == end = do
486 liftIO $ touchForeignPtr startf
487 return $ Skip $ OuterLoop st Nothing
488 step' _ _ (InnerLoopDecodeInit st startf p end) = do
489 x <- liftIO $ peek p
490 -- Note: It is important to use a ">" instead of a "<=" test here for
491 -- GHC to generate code layout for default branch prediction for the
492 -- common case. This is fragile and might change with the compiler
493 -- versions, we need a more reliable "likely" primitive to control
494 -- branch predication.
495 case x > 0x7f of
496 False ->
497 return $ Skip $ YAndC
498 (unsafeChr (fromIntegral x))
499 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
500 -- Using a separate state here generates a jump to a separate code
501 -- block in the core which seems to perform slightly better for the
502 -- non-ascii case.
503 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
505 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
506 let (Tuple' sv cp) = decode0 table x
507 return $
508 case sv of
509 12 ->
510 Skip $
511 transliterateOrError
512 "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
513 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
514 0 -> error "unreachable state"
515 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
516 step' _ _ (InnerLoopDecoding st startf p end sv cp)
517 | p == end = do
518 liftIO $ touchForeignPtr startf
519 return $ Skip $ OuterLoop st (Just (sv, cp))
520 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
521 x <- liftIO $ peek p
522 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
523 return $
524 case sv of
525 0 ->
526 Skip $
527 YAndC
528 (unsafeChr cp)
529 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
530 12 ->
531 Skip $
532 transliterateOrError
533 "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
534 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
535 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
536 step' _ _ (YAndC c s) = return $ Yield c s
537 step' _ _ D = return Stop
539{-# INLINE decodeUtf8ArraysD #-}
540decodeUtf8ArraysD ::
541 MonadIO m
542 => Stream m (A.Array Word8)
543 -> Stream m Char
544decodeUtf8ArraysD = decodeUtf8ArraysWithD ErrorOnCodingFailure
546{-# INLINE decodeUtf8ArraysLenientD #-}
547decodeUtf8ArraysLenientD ::
548 MonadIO m
549 => Stream m (A.Array Word8)
550 -> Stream m Char
551decodeUtf8ArraysLenientD = decodeUtf8ArraysWithD TransliterateCodingFailure
553data EncodeState s = EncodeState s !WList
555-- More yield points improve performance, but I am not sure if they can cause
556-- too much code bloat or some trouble with fusion. So keeping only two yield
557-- points for now, one for the ascii chars (fast path) and one for all other
558-- paths (slow path).
559{-# INLINE_NORMAL encodeUtf8D #-}
560encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
561encodeUtf8D (Stream step state) = Stream step' (EncodeState state WNil)
562 where
563 {-# INLINE_LATE step' #-}
564 step' gst (EncodeState st WNil) = do
565 r <- step (adaptState gst) st
566 return $
567 case r of
568 Yield c s ->
569 case ord c of
570 x
571 | x <= 0x7F ->
572 Yield (fromIntegral x) (EncodeState s WNil)
573 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
574 | x <= 0xFFFF ->
575 if isSurrogate c
576 then error
577 "Streamly.Internal.Data.Stream.StreamD.encodeUtf8: Encountered a surrogate"
578 else Skip (EncodeState s (ord3 c))
579 | otherwise -> Skip (EncodeState s (ord4 c))
580 Skip s -> Skip (EncodeState s WNil)
581 Stop -> Stop
582 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
585-- | Decode a stream of bytes to Unicode characters by mapping each byte to a
586-- corresponding Unicode 'Char' in 0-255 range.
587--
588-- /Since: 0.7.0/
589{-# INLINE decodeLatin1 #-}
590decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char
591decodeLatin1 = S.map (unsafeChr . fromIntegral)
593-- | Encode a stream of Unicode characters to bytes by mapping each character
594-- to a byte in 0-255 range. Throws an error if the input stream contains
595-- characters beyond 255.
596--
597-- /Since: 0.7.0/
598{-# INLINE encodeLatin1 #-}
599encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8
600encodeLatin1 = S.map convert
601 where
602 convert c =
603 let codepoint = ord c
604 in if codepoint > 255
605 then error $ "Streamly.String.encodeLatin1 invalid " ++
606 "input char codepoint " ++ show codepoint
607 else fromIntegral codepoint
609-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond
610-- 255 to (incorrect) chars in 0-255 range. No error or exception is thrown
611-- when such truncation occurs.
612--
613-- /Since: 0.7.0/
614{-# INLINE encodeLatin1Lax #-}
615encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
616encodeLatin1Lax = S.map (fromIntegral . ord)
618-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
619-- The incoming stream is truncated if an invalid codepoint is encountered.
620--
621-- /Since: 0.7.0/
622{-# INLINE decodeUtf8 #-}
623decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char
624decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD
626-- |
627--
628-- /Internal/
629{-# INLINE decodeUtf8Arrays #-}
630decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
631decodeUtf8Arrays = D.fromStreamD . decodeUtf8ArraysD . D.toStreamD
633-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
634-- Any invalid codepoint encountered is replaced with the unicode replacement
635-- character.
636--
637-- /Since: 0.7.0/
638{-# INLINE decodeUtf8Lax #-}
639decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char
640decodeUtf8Lax = D.fromStreamD . decodeUtf8LenientD . D.toStreamD
642-- |
643--
644-- /Internal/
645{-# INLINE decodeUtf8Either #-}
646decodeUtf8Either :: (Monad m, IsStream t)
647 => t m Word8 -> t m (Either DecodeError Char)
648decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD
650-- |
651--
652-- /Internal/
653{-# INLINE resumeDecodeUtf8Either #-}
654resumeDecodeUtf8Either
655 :: (Monad m, IsStream t)
656 => DecodeState
657 -> CodePoint
658 -> t m Word8
659 -> t m (Either DecodeError Char)
660resumeDecodeUtf8Either st cp =
661 D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD
663-- |
664--
665-- /Internal/
666{-# INLINE decodeUtf8ArraysLenient #-}
667decodeUtf8ArraysLenient ::
668 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
669decodeUtf8ArraysLenient =
670 D.fromStreamD . decodeUtf8ArraysLenientD . D.toStreamD
672-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.
673--
674-- /Since: 0.7.0/
675{-# INLINE encodeUtf8 #-}
676encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
677encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD
679-- | See section "3.9 Unicode Encoding Forms" in
680-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf
681--
682{-# INLINE_NORMAL encodeUtf8LaxD #-}
683encodeUtf8LaxD :: Monad m => Stream m Char -> Stream m Word8
684encodeUtf8LaxD (Stream step state) = Stream step' (EncodeState state WNil)
685 where
686 {-# INLINE_LATE step' #-}
687 step' gst (EncodeState st WNil) = do
688 r <- step (adaptState gst) st
689 return $
690 case r of
691 Yield c s ->
692 case ord c of
693 x | x <= 0x7F ->
694 Yield (fromIntegral x) (EncodeState s WNil)
695 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
696 | x <= 0xFFFF ->
697 if isSurrogate c
698 then Skip $
699 EncodeState
700 s
701 (WCons 239 (WCons 191 (WCons 189 WNil)))
702 else Skip (EncodeState s (ord3 c))
703 | otherwise -> Skip (EncodeState s (ord4 c))
704 Skip s -> Skip (EncodeState s WNil)
705 Stop -> Stop
706 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
709-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
710-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the
711-- Unicode replacement character U+FFFD.
712--
713-- /Since: 0.8.0/
714{-# INLINE encodeUtf8Lax #-}
715encodeUtf8Lax :: (Monad m, IsStream t) => t m Char -> t m Word8
716encodeUtf8Lax = D.fromStreamD . encodeUtf8LaxD . D.toStreamD
718{-
719-------------------------------------------------------------------------------
720-- Utility operations on strings
721-------------------------------------------------------------------------------
723strip :: IsStream t => t m Char -> t m Char
724strip = undefined
726stripEnd :: IsStream t => t m Char -> t m Char
727stripEnd = undefined
728-}
730-- | Remove leading whitespace from a string.
731--
732-- > stripStart = S.dropWhile isSpace
733--
734-- /Internal/
735{-# INLINE stripStart #-}
736stripStart :: (Monad m, IsStream t) => t m Char -> t m Char
737stripStart = S.dropWhile isSpace
739-- | Fold each line of the stream using the supplied 'Fold'
740-- and stream the result.
741--
742-- >>> S.toList $ lines FL.toList (S.fromList "lines\nthis\nstring\n\n\n")
743-- ["lines", "this", "string", "", ""]
744--
745-- > lines = S.splitOnSuffix (== '\n')
746--
747-- /Internal/
748{-# INLINE lines #-}
749lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
750lines = S.splitOnSuffix (== '\n')
752foreign import ccall unsafe "u_iswspace"
753 iswspace :: Int -> Int
755-- | Code copied from base/Data.Char to INLINE it
756{-# INLINE isSpace #-}
757isSpace :: Char -> Bool
758isSpace c
759 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0
760 | otherwise = iswspace (ord c) /= 0
761 where
762 uc = fromIntegral (ord c) :: Word
764-- | Fold each word of the stream using the supplied 'Fold'
765-- and stream the result.
766--
767-- >>> S.toList $ words FL.toList (S.fromList "fold these words")
768-- ["fold", "these", "words"]
769--
770-- > words = S.wordsBy isSpace
771--
772-- /Internal/
773{-# INLINE words #-}
774words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
775words = S.wordsBy isSpace
777-- | Unfold a stream to character streams using the supplied 'Unfold'
778-- and concat the results suffixing a newline character @\\n@ to each stream.
779--
780-- /Internal/
781{-# INLINE unlines #-}
782unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
783unlines = S.interposeSuffix '\n'
785-- | Unfold the elements of a stream to character streams using the supplied
786-- 'Unfold' and concat the results with a whitespace character infixed between
787-- the streams.
788--
789-- /Internal/
790{-# INLINE unwords #-}
791unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
792unwords = S.interpose ' '