git.iko.soy/streamly
on cf63b4e help sign in
streamly/src/Streamly/Internal/Unicode/Stream.hs
1016 lines 37 kB history raw
1-- |
2-- Module : Streamly.Internal.Unicode.Stream
3-- Copyright : (c) 2018 Composewell Technologies
4-- (c) Bjoern Hoehrmann 2008-2009
5--
6-- License : BSD-3-Clause
7-- Maintainer : streamly@composewell.com
8-- Stability : experimental
9-- Portability : GHC
10--
12module Streamly.Internal.Unicode.Stream
13 (
14 -- * Construction (Decoding)
15 decodeLatin1
17 -- ** UTF-8 Decoding
18 , decodeUtf8
19 , decodeUtf8'
20 , decodeUtf8_
22 -- ** Resumable UTF-8 Decoding
23 , DecodeError(..)
24 , DecodeState
25 , CodePoint
26 , decodeUtf8Either
27 , resumeDecodeUtf8Either
29 -- ** UTF-8 Array Stream Decoding
30 , decodeUtf8Arrays
31 , decodeUtf8Arrays'
32 , decodeUtf8Arrays_
34 -- * Elimination (Encoding)
35 -- ** Latin1 Encoding
36 , encodeLatin1
37 , encodeLatin1'
38 , encodeLatin1_
40 -- ** UTF-8 Encoding
41 , encodeUtf8
42 , encodeUtf8'
43 , encodeUtf8_
44 , encodeStrings
45 {-
46 -- * Operations on character strings
47 , strip -- (dropAround isSpace)
48 , stripEnd
49 -}
51 -- * Transformation
52 , stripHead
53 , lines
54 , words
55 , unlines
56 , unwords
58 -- * StreamD UTF8 Encoding / Decoding transformations.
59 , decodeUtf8D
60 , decodeUtf8D'
61 , decodeUtf8D_
62 , encodeUtf8D
63 , encodeUtf8D'
64 , encodeUtf8D_
65 , decodeUtf8EitherD
66 , resumeDecodeUtf8EitherD
67 , decodeUtf8ArraysD
68 , decodeUtf8ArraysD'
69 , decodeUtf8ArraysD_
71 -- * Deprecations
72 , decodeUtf8Lax
73 , encodeLatin1Lax
74 , encodeUtf8Lax
75 )
76where
78#include "inline.hs"
80import Control.Monad.IO.Class (MonadIO, liftIO)
81import Data.Bits (shiftR, shiftL, (.|.), (.&.))
82import Data.Char (chr, ord)
83import Data.Word (Word8)
84import Foreign.ForeignPtr (touchForeignPtr)
85import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
86import Foreign.Storable (Storable(..))
87import Fusion.Plugin.Types (Fuse(..))
88import GHC.Base (assert, unsafeChr)
89import GHC.ForeignPtr (ForeignPtr (..))
90import GHC.IO.Encoding.Failure (isSurrogate)
91import GHC.Ptr (Ptr (..), plusPtr)
92import System.IO.Unsafe (unsafePerformIO)
93import Streamly.Data.Fold (Fold)
94import Streamly.Data.Array.Foreign (Array)
95import Streamly.Internal.Data.Unfold (Unfold)
96import Streamly.Internal.Data.SVar (adaptState)
97import Streamly.Internal.Data.Stream.IsStream (IsStream)
98import Streamly.Internal.Data.Stream.Serial (SerialT)
99import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
100import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))
102import qualified Streamly.Internal.Data.Unfold as Unfold
103import qualified Streamly.Internal.Data.Stream.Serial as Serial
104import qualified Streamly.Internal.Data.Array.Foreign as Array
105import qualified Streamly.Internal.Data.Array.Foreign.Type as A
106import qualified Streamly.Internal.Data.Stream.IsStream as S
107import qualified Streamly.Internal.Data.Stream.StreamD as D
109import Prelude hiding (lines, words, unlines, unwords)
111-- $setup
112-- >>> :m
113-- >>> import Prelude hiding (lines, words, unlines, unwords)
114-- >>> import qualified Streamly.Prelude as Stream
115-- >>> import qualified Streamly.Data.Fold as Fold
116-- >>> import Streamly.Internal.Unicode.Stream
118-------------------------------------------------------------------------------
119-- Latin1 decoding
120-------------------------------------------------------------------------------
122-- | Decode a stream of bytes to Unicode characters by mapping each byte to a
123-- corresponding Unicode 'Char' in 0-255 range.
124--
125-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
126--
127-- @since 0.8.0
128{-# INLINE decodeLatin1 #-}
129decodeLatin1 :: (IsStream t, Monad m) => t m Word8 -> t m Char
130decodeLatin1 = S.map (unsafeChr . fromIntegral)
132-------------------------------------------------------------------------------
133-- Latin1 encoding
134-------------------------------------------------------------------------------
136-- | Encode a stream of Unicode characters to bytes by mapping each character
137-- to a byte in 0-255 range. Throws an error if the input stream contains
138-- characters beyond 255.
139--
140-- @since 0.8.0
141{-# INLINE encodeLatin1' #-}
142encodeLatin1' :: (IsStream t, Monad m) => t m Char -> t m Word8
143encodeLatin1' = S.map convert
144 where
145 convert c =
146 let codepoint = ord c
147 in if codepoint > 255
148 then error $ "Streamly.String.encodeLatin1 invalid " ++
149 "input char codepoint " ++ show codepoint
150 else fromIntegral codepoint
152-- | Like 'encodeLatin1'' but silently truncates and maps input characters beyond
153-- 255 to (incorrect) chars in 0-255 range. No error or exception is thrown
154-- when such truncation occurs.
155--
156-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
157--
158-- /Since: 0.8.0 (Lenient Behaviour)/
159{-# INLINE encodeLatin1 #-}
160encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8
161encodeLatin1 = S.map (fromIntegral . ord)
163-- | Like 'encodeLatin1' but drops the input characters beyond 255.
164--
165-- @since 0.8.0
166{-# INLINE encodeLatin1_ #-}
167encodeLatin1_ :: (IsStream t, Monad m) => t m Char -> t m Word8
168encodeLatin1_ = S.map (fromIntegral . ord) . S.filter (<= chr 255)
170-- | Same as 'encodeLatin1'
171--
172{-# DEPRECATED encodeLatin1Lax "Please use 'encodeLatin1' instead" #-}
173{-# INLINE encodeLatin1Lax #-}
174encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
175encodeLatin1Lax = encodeLatin1
177-------------------------------------------------------------------------------
178-- UTF-8 decoding
179-------------------------------------------------------------------------------
181-- Int helps in cheaper conversion from Int to Char
182type CodePoint = Int
183type DecodeState = Word8
185-- We can divide the errors in three general categories:
186-- * A non-starter was encountered in a begin state
187-- * A starter was encountered without completing a codepoint
188-- * The last codepoint was not complete (input underflow)
189--
190-- Need to separate resumable and non-resumable error. In case of non-resumable
191-- error we can also provide the failing byte. In case of resumable error the
192-- state can be opaque.
193--
194data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
196-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
198-- XXX Use names decodeSuccess = 0, decodeFailure = 12
200decodeTable :: [Word8]
201decodeTable = [
202 -- The first part of the table maps bytes to character classes that
203 -- to reduce the size of the transition table and create bitmasks.
204 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,
205 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,
206 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,
207 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,
208 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,
209 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,
210 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,
211 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,
213 -- The second part is a transition table that maps a combination
214 -- of a state of the automaton and a character class to a state.
215 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
216 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
217 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
218 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
219 12,36,12,12,12,12,12,12,12,12,12,12
220 ]
222{-# NOINLINE utf8d #-}
223utf8d :: A.Array Word8
224utf8d =
225 unsafePerformIO
226 -- Aligning to cacheline makes a barely noticeable difference
227 -- XXX currently alignment is not implemented for unmanaged allocation
228 $ D.fold (A.writeNAlignedUnmanaged 64 (length decodeTable))
229 (D.fromList decodeTable)
231-- | Return element at the specified index without checking the bounds.
232-- and without touching the foreign ptr.
233{-# INLINE_NORMAL unsafePeekElemOff #-}
234unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
235unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
237-- decode is split into two separate cases to avoid branching instructions.
238-- From the higher level flow we already know which case we are in so we can
239-- call the appropriate decode function.
240--
241-- When the state is 0
242{-# INLINE decode0 #-}
243decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
244decode0 table byte =
245 let !t = table `unsafePeekElemOff` fromIntegral byte
246 !codep' = (0xff `shiftR` fromIntegral t) .&. fromIntegral byte
247 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
248 in assert ((byte > 0x7f || error showByte)
249 && (state' /= 0 || error (showByte ++ showTable)))
250 (Tuple' state' codep')
252 where
254 utf8table =
255 let !(Ptr addr) = table
256 end = table `plusPtr` 364
257 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
258 showByte = "Streamly: decode0: byte: " ++ show byte
259 showTable = " table: " ++ show utf8table
261-- When the state is not 0
262{-# INLINE decode1 #-}
263decode1
264 :: Ptr Word8
265 -> DecodeState
266 -> CodePoint
267 -> Word8
268 -> Tuple' DecodeState CodePoint
269decode1 table state codep byte =
270 -- Remember codep is Int type!
271 -- Can it be unsafe to convert the resulting Int to Char?
272 let !t = table `unsafePeekElemOff` fromIntegral byte
273 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
274 !state' = table `unsafePeekElemOff`
275 (256 + fromIntegral state + fromIntegral t)
276 in assert (codep' <= 0x10FFFF
277 || error (showByte ++ showState state codep))
278 (Tuple' state' codep')
279 where
281 utf8table =
282 let !(Ptr addr) = table
283 end = table `plusPtr` 364
284 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
285 showByte = "Streamly: decode1: byte: " ++ show byte
286 showState st cp =
287 " state: " ++ show st ++
288 " codepoint: " ++ show cp ++
289 " table: " ++ show utf8table
291-------------------------------------------------------------------------------
292-- Resumable UTF-8 decoding
293-------------------------------------------------------------------------------
295{-# ANN type UTF8DecodeState Fuse #-}
296data UTF8DecodeState s a
297 = UTF8DecodeInit s
298 | UTF8DecodeInit1 s Word8
299 | UTF8DecodeFirst s Word8
300 | UTF8Decoding s !DecodeState !CodePoint
301 | YieldAndContinue a (UTF8DecodeState s a)
302 | Done
304{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}
305resumeDecodeUtf8EitherD
306 :: Monad m
307 => DecodeState
308 -> CodePoint
309 -> Stream m Word8
310 -> Stream m (Either DecodeError Char)
311resumeDecodeUtf8EitherD dst codep (Stream step state) =
312 let A.Array p _ = utf8d
313 !ptr = unsafeForeignPtrToPtr p
314 stt =
315 if dst == 0
316 then UTF8DecodeInit state
317 else UTF8Decoding state dst codep
318 in Stream (step' ptr) stt
319 where
320 {-# INLINE_LATE step' #-}
321 step' _ gst (UTF8DecodeInit st) = do
322 r <- step (adaptState gst) st
323 return $ case r of
324 Yield x s -> Skip (UTF8DecodeInit1 s x)
325 Skip s -> Skip (UTF8DecodeInit s)
326 Stop -> Skip Done
328 step' _ _ (UTF8DecodeInit1 st x) = do
329 -- Note: It is important to use a ">" instead of a "<=" test
330 -- here for GHC to generate code layout for default branch
331 -- prediction for the common case. This is fragile and might
332 -- change with the compiler versions, we need a more reliable
333 -- "likely" primitive to control branch predication.
334 case x > 0x7f of
335 False ->
336 return $ Skip $ YieldAndContinue
337 (Right $ unsafeChr (fromIntegral x))
338 (UTF8DecodeInit st)
339 -- Using a separate state here generates a jump to a
340 -- separate code block in the core which seems to perform
341 -- slightly better for the non-ascii case.
342 True -> return $ Skip $ UTF8DecodeFirst st x
344 -- XXX should we merge it with UTF8DecodeInit1?
345 step' table _ (UTF8DecodeFirst st x) = do
346 let (Tuple' sv cp) = decode0 table x
347 return $
348 case sv of
349 12 ->
350 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
351 (UTF8DecodeInit st)
352 0 -> error "unreachable state"
353 _ -> Skip (UTF8Decoding st sv cp)
355 -- We recover by trying the new byte x a starter of a new codepoint.
356 -- XXX on error need to report the next byte "x" as well.
357 -- XXX need to use the same recovery in array decoding routine as well
358 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
359 r <- step (adaptState gst) st
360 case r of
361 Yield x s -> do
362 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
363 return $
364 case sv of
365 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
366 (UTF8DecodeInit s)
367 12 ->
368 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
369 (UTF8DecodeInit1 s x)
370 _ -> Skip (UTF8Decoding s sv cp)
371 Skip s -> return $ Skip (UTF8Decoding s statePtr codepointPtr)
372 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
374 step' _ _ (YieldAndContinue c s) = return $ Yield c s
375 step' _ _ Done = return Stop
377-- XXX We can use just one API, and define InitState = 0 and InitCodePoint = 0
378-- to use as starting state.
379--
380{-# INLINE_NORMAL decodeUtf8EitherD #-}
381decodeUtf8EitherD :: Monad m
382 => Stream m Word8 -> Stream m (Either DecodeError Char)
383decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0
385-- |
386--
387-- /Pre-release/
388{-# INLINE decodeUtf8Either #-}
389decodeUtf8Either :: (Monad m, IsStream t)
390 => t m Word8 -> t m (Either DecodeError Char)
391decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD
393-- |
394--
395-- /Pre-release/
396{-# INLINE resumeDecodeUtf8Either #-}
397resumeDecodeUtf8Either
398 :: (Monad m, IsStream t)
399 => DecodeState
400 -> CodePoint
401 -> t m Word8
402 -> t m (Either DecodeError Char)
403resumeDecodeUtf8Either st cp =
404 D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD
406-------------------------------------------------------------------------------
407-- One shot decoding
408-------------------------------------------------------------------------------
410data CodingFailureMode
411 = TransliterateCodingFailure
412 | ErrorOnCodingFailure
413 | DropOnCodingFailure
414 deriving (Show)
416{-# INLINE replacementChar #-}
417replacementChar :: Char
418replacementChar = '\xFFFD'
420-- XXX write it as a parser and use parseMany to decode a stream, need to check
421-- if that preserves the same performance. Or we can use a resumable parser
422-- that parses a chunk at a time.
423--
424-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that
425-- decodeUtf8Either preserves the performance characterstics.
426--
427{-# INLINE_NORMAL decodeUtf8WithD #-}
428decodeUtf8WithD :: Monad m
429 => CodingFailureMode -> Stream m Word8 -> Stream m Char
430decodeUtf8WithD cfm (Stream step state) =
431 let A.Array p _ = utf8d
432 !ptr = unsafeForeignPtrToPtr p
433 in Stream (step' ptr) (UTF8DecodeInit state)
435 where
437 prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: "
439 {-# INLINE handleError #-}
440 handleError e s =
441 case cfm of
442 ErrorOnCodingFailure -> error e
443 TransliterateCodingFailure -> YieldAndContinue replacementChar s
444 DropOnCodingFailure -> s
446 {-# INLINE handleUnderflow #-}
447 handleUnderflow =
448 case cfm of
449 ErrorOnCodingFailure -> error $ prefix ++ "Not enough input"
450 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
451 DropOnCodingFailure -> Done
453 {-# INLINE_LATE step' #-}
454 step' _ gst (UTF8DecodeInit st) = do
455 r <- step (adaptState gst) st
456 return $ case r of
457 Yield x s -> Skip (UTF8DecodeInit1 s x)
458 Skip s -> Skip (UTF8DecodeInit s)
459 Stop -> Skip Done
461 step' _ _ (UTF8DecodeInit1 st x) = do
462 -- Note: It is important to use a ">" instead of a "<=" test
463 -- here for GHC to generate code layout for default branch
464 -- prediction for the common case. This is fragile and might
465 -- change with the compiler versions, we need a more reliable
466 -- "likely" primitive to control branch predication.
467 case x > 0x7f of
468 False ->
469 return $ Skip $ YieldAndContinue
470 (unsafeChr (fromIntegral x))
471 (UTF8DecodeInit st)
472 -- Using a separate state here generates a jump to a
473 -- separate code block in the core which seems to perform
474 -- slightly better for the non-ascii case.
475 True -> return $ Skip $ UTF8DecodeFirst st x
477 -- XXX should we merge it with UTF8DecodeInit1?
478 step' table _ (UTF8DecodeFirst st x) = do
479 let (Tuple' sv cp) = decode0 table x
480 return $
481 case sv of
482 12 ->
483 let msg = prefix ++ "Invalid first UTF8 byte " ++ show x
484 in Skip $ handleError msg (UTF8DecodeInit st)
485 0 -> error "unreachable state"
486 _ -> Skip (UTF8Decoding st sv cp)
488 -- We recover by trying the new byte x as a starter of a new codepoint.
489 -- XXX need to use the same recovery in array decoding routine as well
490 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
491 r <- step (adaptState gst) st
492 case r of
493 Yield x s -> do
494 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
495 return $ case sv of
496 0 -> Skip $ YieldAndContinue
497 (unsafeChr cp) (UTF8DecodeInit s)
498 12 ->
499 let msg = prefix
500 ++ "Invalid subsequent UTF8 byte "
501 ++ show x
502 ++ " in state "
503 ++ show statePtr
504 ++ " accumulated value "
505 ++ show codepointPtr
506 in Skip $ handleError msg (UTF8DecodeInit1 s x)
507 _ -> Skip (UTF8Decoding s sv cp)
508 Skip s -> return $
509 Skip (UTF8Decoding s statePtr codepointPtr)
510 Stop -> return $ Skip handleUnderflow
512 step' _ _ (YieldAndContinue c s) = return $ Yield c s
513 step' _ _ Done = return Stop
515{-# INLINE decodeUtf8D #-}
516decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char
517decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure
519-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
520-- Any invalid codepoint encountered is replaced with the unicode replacement
521-- character.
522--
523-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
524--
525-- /Since: 0.8.0 (Lenient Behaviour)/
526{-# INLINE decodeUtf8 #-}
527decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char
528decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD
530{-# INLINE decodeUtf8D' #-}
531decodeUtf8D' :: Monad m => Stream m Word8 -> Stream m Char
532decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure
534-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
535-- The function throws an error if an invalid codepoint is encountered.
536--
537-- @since 0.8.0
538{-# INLINE decodeUtf8' #-}
539decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char
540decodeUtf8' = D.fromStreamD . decodeUtf8D' . D.toStreamD
542{-# INLINE decodeUtf8D_ #-}
543decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char
544decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure
546-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
547-- Any invalid codepoint encountered is dropped.
548--
549-- @since 0.8.0
550{-# INLINE decodeUtf8_ #-}
551decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char
552decodeUtf8_ = D.fromStreamD . decodeUtf8D_ . D.toStreamD
554-- | Same as 'decodeUtf8'
555--
556{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-}
557{-# INLINE decodeUtf8Lax #-}
558decodeUtf8Lax :: (IsStream t, Monad m) => t m Word8 -> t m Char
559decodeUtf8Lax = decodeUtf8
561-------------------------------------------------------------------------------
562-- Decoding Array Streams
563-------------------------------------------------------------------------------
565{-# ANN type FlattenState Fuse #-}
566data FlattenState s a
567 = OuterLoop s !(Maybe (DecodeState, CodePoint))
568 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
569 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
570 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
571 !DecodeState !CodePoint
572 | YAndC !Char (FlattenState s a) -- These constructors can be
573 -- encoded in the UTF8DecodeState
574 -- type, I prefer to keep these
575 -- flat even though that means
576 -- coming up with new names
577 | D
579-- The normal decodeUtf8 above should fuse with flattenArrays
580-- to create this exact code but it doesn't for some reason, as of now this
581-- remains the fastest way I could figure out to decodeUtf8.
582--
583-- XXX Add Proper error messages
584{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
585decodeUtf8ArraysWithD ::
586 MonadIO m
587 => CodingFailureMode
588 -> Stream m (A.Array Word8)
589 -> Stream m Char
590decodeUtf8ArraysWithD cfm (Stream step state) =
591 let A.Array p _ = utf8d
592 !ptr = unsafeForeignPtrToPtr p
593 in Stream (step' ptr) (OuterLoop state Nothing)
594 where
595 {-# INLINE transliterateOrError #-}
596 transliterateOrError e s =
597 case cfm of
598 ErrorOnCodingFailure -> error e
599 TransliterateCodingFailure -> YAndC replacementChar s
600 DropOnCodingFailure -> s
601 {-# INLINE inputUnderflow #-}
602 inputUnderflow =
603 case cfm of
604 ErrorOnCodingFailure ->
605 error $
606 show "Streamly.Internal.Data.Stream.StreamD."
607 ++ "decodeUtf8ArraysWith: Input Underflow"
608 TransliterateCodingFailure -> YAndC replacementChar D
609 DropOnCodingFailure -> D
610 {-# INLINE_LATE step' #-}
611 step' _ gst (OuterLoop st Nothing) = do
612 r <- step (adaptState gst) st
613 return $
614 case r of
615 Yield A.Array {..} s ->
616 let p = unsafeForeignPtrToPtr aStart
617 in Skip (InnerLoopDecodeInit s aStart p aEnd)
618 Skip s -> Skip (OuterLoop s Nothing)
619 Stop -> Skip D
620 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
621 r <- step (adaptState gst) st
622 return $
623 case r of
624 Yield A.Array {..} s ->
625 let p = unsafeForeignPtrToPtr aStart
626 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
627 Skip s -> Skip (OuterLoop s dst)
628 Stop -> Skip inputUnderflow
629 step' _ _ (InnerLoopDecodeInit st startf p end)
630 | p == end = do
631 liftIO $ touchForeignPtr startf
632 return $ Skip $ OuterLoop st Nothing
633 step' _ _ (InnerLoopDecodeInit st startf p end) = do
634 x <- liftIO $ peek p
635 -- Note: It is important to use a ">" instead of a "<=" test here for
636 -- GHC to generate code layout for default branch prediction for the
637 -- common case. This is fragile and might change with the compiler
638 -- versions, we need a more reliable "likely" primitive to control
639 -- branch predication.
640 case x > 0x7f of
641 False ->
642 return $ Skip $ YAndC
643 (unsafeChr (fromIntegral x))
644 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
645 -- Using a separate state here generates a jump to a separate code
646 -- block in the core which seems to perform slightly better for the
647 -- non-ascii case.
648 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
650 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
651 let (Tuple' sv cp) = decode0 table x
652 return $
653 case sv of
654 12 ->
655 Skip $
656 transliterateOrError
657 (
658 "Streamly.Internal.Data.Stream.StreamD."
659 ++ "decodeUtf8ArraysWith: Invalid UTF8"
660 ++ " codepoint encountered"
661 )
662 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
663 0 -> error "unreachable state"
664 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
665 step' _ _ (InnerLoopDecoding st startf p end sv cp)
666 | p == end = do
667 liftIO $ touchForeignPtr startf
668 return $ Skip $ OuterLoop st (Just (sv, cp))
669 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
670 x <- liftIO $ peek p
671 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
672 return $
673 case sv of
674 0 ->
675 Skip $
676 YAndC
677 (unsafeChr cp)
678 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
679 12 ->
680 Skip $
681 transliterateOrError
682 (
683 "Streamly.Internal.Data.Stream.StreamD."
684 ++ "decodeUtf8ArraysWith: Invalid UTF8"
685 ++ " codepoint encountered"
686 )
687 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
688 _ ->
689 Skip
690 (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
691 step' _ _ (YAndC c s) = return $ Yield c s
692 step' _ _ D = return Stop
694{-# INLINE decodeUtf8ArraysD #-}
695decodeUtf8ArraysD ::
696 MonadIO m
697 => Stream m (A.Array Word8)
698 -> Stream m Char
699decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure
701-- |
702--
703-- /Pre-release/
704{-# INLINE decodeUtf8Arrays #-}
705decodeUtf8Arrays ::
706 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
707decodeUtf8Arrays =
708 D.fromStreamD . decodeUtf8ArraysD . D.toStreamD
710{-# INLINE decodeUtf8ArraysD' #-}
711decodeUtf8ArraysD' ::
712 MonadIO m
713 => Stream m (A.Array Word8)
714 -> Stream m Char
715decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure
717-- |
718--
719-- /Pre-release/
720{-# INLINE decodeUtf8Arrays' #-}
721decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
722decodeUtf8Arrays' = D.fromStreamD . decodeUtf8ArraysD' . D.toStreamD
724{-# INLINE decodeUtf8ArraysD_ #-}
725decodeUtf8ArraysD_ ::
726 MonadIO m
727 => Stream m (A.Array Word8)
728 -> Stream m Char
729decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure
731-- |
732--
733-- /Pre-release/
734{-# INLINE decodeUtf8Arrays_ #-}
735decodeUtf8Arrays_ ::
736 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
737decodeUtf8Arrays_ =
738 D.fromStreamD . decodeUtf8ArraysD_ . D.toStreamD
740-------------------------------------------------------------------------------
741-- Encoding Unicode (UTF-8) Characters
742-------------------------------------------------------------------------------
744data WList = WCons !Word8 !WList | WNil
746-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
748{-# INLINE ord2 #-}
749ord2 :: Char -> WList
750ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
751 where
752 n = ord c
753 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
754 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
756{-# INLINE ord3 #-}
757ord3 :: Char -> WList
758ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
759 where
760 n = ord c
761 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
762 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
763 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
765{-# INLINE ord4 #-}
766ord4 :: Char -> WList
767ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
768 where
769 n = ord c
770 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
771 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
772 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
773 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
775{-# ANN type EncodeState Fuse #-}
776data EncodeState s = EncodeState s !WList
778{-# ANN type InvalidAction Fuse #-}
779data InvalidAction =
780 DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid
782replaceInvalid :: s -> Step (EncodeState s) a
783replaceInvalid s =
784 Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil)))
786dropInvalid :: s -> Step (EncodeState s) a
787dropInvalid s = Skip (EncodeState s WNil)
789errorOnInvalid :: s -> Step (EncodeState s) a
790errorOnInvalid _ =
791 error $
792 show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:"
793 ++ "Encountered a surrogate"
795{-# INLINE_NORMAL encodeUtf8DGeneric #-}
796encodeUtf8DGeneric ::
797 Monad m
798 => InvalidAction
799 -> Stream m Char
800 -> Stream m Word8
801encodeUtf8DGeneric act (Stream step state) =
802 Stream step' (EncodeState state WNil)
804 where
806 {-# INLINE_LATE step' #-}
807 step' gst (EncodeState st WNil) = do
808 r <- step (adaptState gst) st
809 return $
810 case r of
811 Yield c s ->
812 case ord c of
813 x | x <= 0x7F ->
814 Yield (fromIntegral x) (EncodeState s WNil)
815 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
816 | x <= 0xFFFF ->
817 case act of
818 DropInvalid ->
819 if isSurrogate c
820 then dropInvalid s
821 else Skip (EncodeState s (ord3 c))
823 ErrorInvalid ->
824 if isSurrogate c
825 then errorOnInvalid s
826 else Skip (EncodeState s (ord3 c))
828 IgnoreInvalid ->
829 Skip (EncodeState s (ord3 c))
831 ReplaceInvalid ->
832 if isSurrogate c
833 then replaceInvalid s
834 else Skip (EncodeState s (ord3 c))
836 | otherwise -> Skip (EncodeState s (ord4 c))
837 Skip s -> Skip (EncodeState s WNil)
838 Stop -> Stop
839 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
841-- More yield points improve performance, but I am not sure if they can cause
842-- too much code bloat or some trouble with fusion. So keeping only two yield
843-- points for now, one for the ascii chars (fast path) and one for all other
844-- paths (slow path).
845{-# INLINE_NORMAL encodeUtf8D' #-}
846encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8
847encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid
849-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When
850-- any invalid character (U+D800-U+D8FF) is encountered in the input stream the
851-- function errors out.
852--
853-- @since 0.8.0
854{-# INLINE encodeUtf8' #-}
855encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8
856encodeUtf8' = D.fromStreamD . encodeUtf8D' . D.toStreamD
858-- | See section "3.9 Unicode Encoding Forms" in
859-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf
860--
861{-# INLINE_NORMAL encodeUtf8D #-}
862encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
863encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid
865-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
866-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the
867-- Unicode replacement character U+FFFD.
868--
869-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
870--
871-- /Since: 0.8.0 (Lenient Behaviour)/
872{-# INLINE encodeUtf8 #-}
873encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
874encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD
876{-# INLINE_NORMAL encodeUtf8D_ #-}
877encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8
878encodeUtf8D_ = encodeUtf8DGeneric DropInvalid
880-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
881-- Invalid characters (U+D800-U+D8FF) in the input stream are dropped.
882--
883-- @since 0.8.0
884{-# INLINE encodeUtf8_ #-}
885encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8
886encodeUtf8_ = D.fromStreamD . encodeUtf8D_ . D.toStreamD
888-- | Same as 'encodeUtf8'
889--
890{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}
891{-# INLINE encodeUtf8Lax #-}
892encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
893encodeUtf8Lax = encodeUtf8
895-------------------------------------------------------------------------------
896-- Encode streams of containers
897-------------------------------------------------------------------------------
899-- | Encode a container to @Array Word8@ provided an unfold to covert it to a
900-- Char stream and an encoding function.
901--
902-- /Internal/
903{-# INLINE encodeObject #-}
904encodeObject :: MonadIO m =>
905 (SerialT m Char -> SerialT m Word8)
906 -> Unfold m a Char
907 -> a
908 -> m (Array Word8)
909encodeObject encode u = S.fold Array.write . encode . S.unfold u
911-- | Encode a stream of container objects using the supplied encoding scheme.
912-- Each object is encoded as an @Array Word8@.
913--
914-- /Internal/
915{-# INLINE encodeObjects #-}
916encodeObjects :: (MonadIO m, IsStream t) =>
917 (SerialT m Char -> SerialT m Word8)
918 -> Unfold m a Char
919 -> t m a
920 -> t m (Array Word8)
921encodeObjects encode u = Serial.mapM (encodeObject encode u)
923-- | Encode a stream of 'String' using the supplied encoding scheme. Each
924-- string is encoded as an @Array Word8@.
925--
926-- @since 0.8.0
927{-# INLINE encodeStrings #-}
928encodeStrings :: (MonadIO m, IsStream t) =>
929 (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)
930encodeStrings encode = encodeObjects encode Unfold.fromList
932{-
933-------------------------------------------------------------------------------
934-- Utility operations on strings
935-------------------------------------------------------------------------------
937strip :: IsStream t => t m Char -> t m Char
938strip = undefined
940stripTail :: IsStream t => t m Char -> t m Char
941stripTail = undefined
942-}
944-- | Remove leading whitespace from a string.
945--
946-- > stripHead = S.dropWhile isSpace
947--
948-- /Pre-release/
949{-# INLINE stripHead #-}
950stripHead :: (Monad m, IsStream t) => t m Char -> t m Char
951stripHead = S.dropWhile isSpace
953-- | Fold each line of the stream using the supplied 'Fold'
954-- and stream the result.
955--
956-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")
957-- ["lines","this","string","",""]
958--
959-- > lines = S.splitOnSuffix (== '\n')
960--
961-- /Pre-release/
962{-# INLINE lines #-}
963lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
964lines = S.splitOnSuffix (== '\n')
966foreign import ccall unsafe "u_iswspace"
967 iswspace :: Int -> Int
969-- | Code copied from base/Data.Char to INLINE it
970{-# INLINE isSpace #-}
971isSpace :: Char -> Bool
972isSpace c
973 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0
974 | otherwise = iswspace (ord c) /= 0
975 where
976 uc = fromIntegral (ord c) :: Word
978-- | Fold each word of the stream using the supplied 'Fold'
979-- and stream the result.
980--
981-- >>> Stream.toList $ words Fold.toList (Stream.fromList "fold these words")
982-- ["fold","these","words"]
983--
984-- > words = S.wordsBy isSpace
985--
986-- /Pre-release/
987{-# INLINE words #-}
988words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
989words = S.wordsBy isSpace
991-- | Unfold a stream to character streams using the supplied 'Unfold'
992-- and concat the results suffixing a newline character @\\n@ to each stream.
993--
994-- @
995-- unlines = Stream.interposeSuffix '\n'
996-- unlines = Stream.intercalateSuffix Unfold.fromList "\n"
997-- @
998--
999-- /Pre-release/
1000{-# INLINE unlines #-}
1001unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1002unlines = S.interposeSuffix '\n'
1004-- | Unfold the elements of a stream to character streams using the supplied
1005-- 'Unfold' and concat the results with a whitespace character infixed between
1006-- the streams.
1008-- @
1009-- unwords = Stream.interpose ' '
1010-- unwords = Stream.intercalate Unfold.fromList " "
1011-- @
1013-- /Pre-release/
1014{-# INLINE unwords #-}
1015unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1016unwords = S.interpose ' '