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