git.iko.soy/streamly
on a05abfc help sign in
streamly/src/Streamly/Internal/Unicode/Stream.hs
1023 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.Storable (Storable(..))
85import Fusion.Plugin.Types (Fuse(..))
86import GHC.Base (assert, unsafeChr)
87import GHC.IO.Encoding.Failure (isSurrogate)
88import GHC.Ptr (Ptr (..), plusPtr)
89import System.IO.Unsafe (unsafePerformIO)
90import Streamly.Internal.Data.Array.Foreign (Array)
91import Streamly.Internal.Data.Array.Foreign.Mut.Type (ArrayContents, touch)
92import Streamly.Internal.Data.Fold (Fold)
93import Streamly.Internal.Data.Stream.IsStream.Type
94 (IsStream, fromStreamD, toStreamD, adapt)
95import Streamly.Internal.Data.Stream.Serial (SerialT)
96import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
97import Streamly.Internal.Data.SVar (adaptState)
98import Streamly.Internal.Data.Tuple.Strict (Tuple'(..))
99import Streamly.Internal.Data.Unfold (Unfold)
100import Streamly.Internal.System.IO (unsafeInlineIO)
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.Unicode.encodeLatin1 invalid " ++
149 "input char codepoint " ++ show codepoint
150 else fromIntegral codepoint
152-- XXX Should we instead replace the invalid chars by NUL or whitespace or some
153-- other control char? That may affect the perf a bit but may be a better
154-- behavior.
155--
156-- | Like 'encodeLatin1'' but silently maps input codepoints beyond 255 to
157-- arbitrary Latin1 chars in 0-255 range. No error or exception is thrown when
158-- such mapping occurs.
159--
160-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
161--
162-- /Since: 0.8.0 (Lenient Behaviour)/
163{-# INLINE encodeLatin1 #-}
164encodeLatin1 :: (IsStream t, Monad m) => t m Char -> t m Word8
165encodeLatin1 = S.map (fromIntegral . ord)
167-- | Like 'encodeLatin1' but drops the input characters beyond 255.
168--
169-- @since 0.8.0
170{-# INLINE encodeLatin1_ #-}
171encodeLatin1_ :: (IsStream t, Monad m) => t m Char -> t m Word8
172encodeLatin1_ = S.map (fromIntegral . ord) . S.filter (<= chr 255)
174-- | Same as 'encodeLatin1'
175--
176{-# DEPRECATED encodeLatin1Lax "Please use 'encodeLatin1' instead" #-}
177{-# INLINE encodeLatin1Lax #-}
178encodeLatin1Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
179encodeLatin1Lax = encodeLatin1
181-------------------------------------------------------------------------------
182-- UTF-8 decoding
183-------------------------------------------------------------------------------
185-- Int helps in cheaper conversion from Int to Char
186type CodePoint = Int
187type DecodeState = Word8
189-- We can divide the errors in three general categories:
190-- * A non-starter was encountered in a begin state
191-- * A starter was encountered without completing a codepoint
192-- * The last codepoint was not complete (input underflow)
193--
194-- Need to separate resumable and non-resumable error. In case of non-resumable
195-- error we can also provide the failing byte. In case of resumable error the
196-- state can be opaque.
197--
198data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
200-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
202-- XXX Use names decodeSuccess = 0, decodeFailure = 12
204decodeTable :: [Word8]
205decodeTable = [
206 -- The first part of the table maps bytes to character classes that
207 -- to reduce the size of the transition table and create bitmasks.
208 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,
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 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,
213 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,
214 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,
215 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,
217 -- The second part is a transition table that maps a combination
218 -- of a state of the automaton and a character class to a state.
219 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
220 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
221 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
222 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
223 12,36,12,12,12,12,12,12,12,12,12,12
224 ]
226{-# NOINLINE utf8d #-}
227utf8d :: A.Array Word8
228utf8d =
229 unsafePerformIO
230 -- Aligning to cacheline makes a barely noticeable difference
231 -- XXX currently alignment is not implemented for unmanaged allocation
232 $ D.fold (A.writeNAlignedUnmanaged 64 (length decodeTable))
233 (D.fromList decodeTable)
235-- | Return element at the specified index without checking the bounds.
236-- and without touching the foreign ptr.
237{-# INLINE_NORMAL unsafePeekElemOff #-}
238unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
239unsafePeekElemOff p i = let !x = unsafeInlineIO $ peekElemOff p i in x
241-- decode is split into two separate cases to avoid branching instructions.
242-- From the higher level flow we already know which case we are in so we can
243-- call the appropriate decode function.
244--
245-- When the state is 0
246{-# INLINE decode0 #-}
247decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
248decode0 table byte =
249 let !t = table `unsafePeekElemOff` fromIntegral byte
250 !codep' = (0xff `shiftR` fromIntegral t) .&. fromIntegral byte
251 !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
252 in assert ((byte > 0x7f || error showByte)
253 && (state' /= 0 || error (showByte ++ showTable)))
254 (Tuple' state' codep')
256 where
258 utf8table =
259 let end = table `plusPtr` 364
260 in A.Array undefined table end :: A.Array Word8
261 showByte = "Streamly: decode0: byte: " ++ show byte
262 showTable = " table: " ++ show utf8table
264-- When the state is not 0
265{-# INLINE decode1 #-}
266decode1
267 :: Ptr Word8
268 -> DecodeState
269 -> CodePoint
270 -> Word8
271 -> Tuple' DecodeState CodePoint
272decode1 table state codep byte =
273 -- Remember codep is Int type!
274 -- Can it be unsafe to convert the resulting Int to Char?
275 let !t = table `unsafePeekElemOff` fromIntegral byte
276 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
277 !state' = table `unsafePeekElemOff`
278 (256 + fromIntegral state + fromIntegral t)
279 in assert (codep' <= 0x10FFFF
280 || error (showByte ++ showState state codep))
281 (Tuple' state' codep')
282 where
284 utf8table =
285 let end = table `plusPtr` 364
286 in A.Array undefined table end :: A.Array Word8
287 showByte = "Streamly: decode1: byte: " ++ show byte
288 showState st cp =
289 " state: " ++ show st ++
290 " codepoint: " ++ show cp ++
291 " table: " ++ show utf8table
293-------------------------------------------------------------------------------
294-- Resumable UTF-8 decoding
295-------------------------------------------------------------------------------
297-- Strangely, GHCJS hangs linking template-haskell with this
298#ifndef __GHCJS__
299{-# ANN type UTF8DecodeState Fuse #-}
300#endif
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 = 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 = fromStreamD . decodeUtf8EitherD . 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 fromStreamD . resumeDecodeUtf8EitherD st cp . 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 _ ptr _ = utf8d
437 in Stream (step' ptr) (UTF8DecodeInit state)
439 where
441 prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: "
443 {-# INLINE handleError #-}
444 handleError e s =
445 case cfm of
446 ErrorOnCodingFailure -> error e
447 TransliterateCodingFailure -> YieldAndContinue replacementChar s
448 DropOnCodingFailure -> s
450 {-# INLINE handleUnderflow #-}
451 handleUnderflow =
452 case cfm of
453 ErrorOnCodingFailure -> error $ prefix ++ "Not enough input"
454 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
455 DropOnCodingFailure -> Done
457 {-# INLINE_LATE step' #-}
458 step' _ gst (UTF8DecodeInit st) = do
459 r <- step (adaptState gst) st
460 return $ case r of
461 Yield x s -> Skip (UTF8DecodeInit1 s x)
462 Skip s -> Skip (UTF8DecodeInit s)
463 Stop -> Skip Done
465 step' _ _ (UTF8DecodeInit1 st x) = do
466 -- Note: It is important to use a ">" instead of a "<=" test
467 -- here for GHC to generate code layout for default branch
468 -- prediction for the common case. This is fragile and might
469 -- change with the compiler versions, we need a more reliable
470 -- "likely" primitive to control branch predication.
471 case x > 0x7f of
472 False ->
473 return $ Skip $ YieldAndContinue
474 (unsafeChr (fromIntegral x))
475 (UTF8DecodeInit st)
476 -- Using a separate state here generates a jump to a
477 -- separate code block in the core which seems to perform
478 -- slightly better for the non-ascii case.
479 True -> return $ Skip $ UTF8DecodeFirst st x
481 -- XXX should we merge it with UTF8DecodeInit1?
482 step' table _ (UTF8DecodeFirst st x) = do
483 let (Tuple' sv cp) = decode0 table x
484 return $
485 case sv of
486 12 ->
487 let msg = prefix ++ "Invalid first UTF8 byte " ++ show x
488 in Skip $ handleError msg (UTF8DecodeInit st)
489 0 -> error "unreachable state"
490 _ -> Skip (UTF8Decoding st sv cp)
492 -- We recover by trying the new byte x as a starter of a new codepoint.
493 -- XXX need to use the same recovery in array decoding routine as well
494 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
495 r <- step (adaptState gst) st
496 case r of
497 Yield x s -> do
498 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
499 return $ case sv of
500 0 -> Skip $ YieldAndContinue
501 (unsafeChr cp) (UTF8DecodeInit s)
502 12 ->
503 let msg = prefix
504 ++ "Invalid subsequent UTF8 byte "
505 ++ show x
506 ++ " in state "
507 ++ show statePtr
508 ++ " accumulated value "
509 ++ show codepointPtr
510 in Skip $ handleError msg (UTF8DecodeInit1 s x)
511 _ -> Skip (UTF8Decoding s sv cp)
512 Skip s -> return $
513 Skip (UTF8Decoding s statePtr codepointPtr)
514 Stop -> return $ Skip handleUnderflow
516 step' _ _ (YieldAndContinue c s) = return $ Yield c s
517 step' _ _ Done = return Stop
519{-# INLINE decodeUtf8D #-}
520decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char
521decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure
523-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
524-- Any invalid codepoint encountered is replaced with the unicode replacement
525-- character.
526--
527-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
528--
529-- /Since: 0.8.0 (Lenient Behaviour)/
530{-# INLINE decodeUtf8 #-}
531decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char
532decodeUtf8 = fromStreamD . decodeUtf8D . toStreamD
534{-# INLINE decodeUtf8D' #-}
535decodeUtf8D' :: Monad m => Stream m Word8 -> Stream m Char
536decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure
538-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
539-- The function throws an error if an invalid codepoint is encountered.
540--
541-- @since 0.8.0
542{-# INLINE decodeUtf8' #-}
543decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char
544decodeUtf8' = fromStreamD . decodeUtf8D' . toStreamD
546{-# INLINE decodeUtf8D_ #-}
547decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char
548decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure
550-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
551-- Any invalid codepoint encountered is dropped.
552--
553-- @since 0.8.0
554{-# INLINE decodeUtf8_ #-}
555decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char
556decodeUtf8_ = fromStreamD . decodeUtf8D_ . toStreamD
558-- | Same as 'decodeUtf8'
559--
560{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-}
561{-# INLINE decodeUtf8Lax #-}
562decodeUtf8Lax :: (IsStream t, Monad m) => t m Word8 -> t m Char
563decodeUtf8Lax = decodeUtf8
565-------------------------------------------------------------------------------
566-- Decoding Array Streams
567-------------------------------------------------------------------------------
569#ifndef __GHCJS__
570{-# ANN type FlattenState Fuse #-}
571#endif
572data FlattenState s a
573 = OuterLoop s !(Maybe (DecodeState, CodePoint))
574 | InnerLoopDecodeInit s ArrayContents !(Ptr a) !(Ptr a)
575 | InnerLoopDecodeFirst s ArrayContents !(Ptr a) !(Ptr a) Word8
576 | InnerLoopDecoding s ArrayContents !(Ptr a) !(Ptr a)
577 !DecodeState !CodePoint
578 | YAndC !Char (FlattenState s a) -- These constructors can be
579 -- encoded in the UTF8DecodeState
580 -- type, I prefer to keep these
581 -- flat even though that means
582 -- coming up with new names
583 | D
585-- The normal decodeUtf8 above should fuse with flattenArrays
586-- to create this exact code but it doesn't for some reason, as of now this
587-- remains the fastest way I could figure out to decodeUtf8.
588--
589-- XXX Add Proper error messages
590{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
591decodeUtf8ArraysWithD ::
592 MonadIO m
593 => CodingFailureMode
594 -> Stream m (A.Array Word8)
595 -> Stream m Char
596decodeUtf8ArraysWithD cfm (Stream step state) =
597 let A.Array _ ptr _ = utf8d
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 Skip (InnerLoopDecodeInit s arrContents arrStart aEnd)
622 Skip s -> Skip (OuterLoop s Nothing)
623 Stop -> Skip D
624 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
625 r <- step (adaptState gst) st
626 return $
627 case r of
628 Yield A.Array {..} s ->
629 Skip (InnerLoopDecoding s arrContents arrStart aEnd ds cp)
630 Skip s -> Skip (OuterLoop s dst)
631 Stop -> Skip inputUnderflow
632 step' _ _ (InnerLoopDecodeInit st startf p end)
633 | p == end = do
634 liftIO $ touch startf
635 return $ Skip $ OuterLoop st Nothing
636 step' _ _ (InnerLoopDecodeInit st startf p end) = do
637 x <- liftIO $ peek p
638 -- Note: It is important to use a ">" instead of a "<=" test here for
639 -- GHC to generate code layout for default branch prediction for the
640 -- common case. This is fragile and might change with the compiler
641 -- versions, we need a more reliable "likely" primitive to control
642 -- branch predication.
643 case x > 0x7f of
644 False ->
645 return $ Skip $ YAndC
646 (unsafeChr (fromIntegral x))
647 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
648 -- Using a separate state here generates a jump to a separate code
649 -- block in the core which seems to perform slightly better for the
650 -- non-ascii case.
651 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
653 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
654 let (Tuple' sv cp) = decode0 table x
655 return $
656 case sv of
657 12 ->
658 Skip $
659 transliterateOrError
660 (
661 "Streamly.Internal.Data.Stream.StreamD."
662 ++ "decodeUtf8ArraysWith: Invalid UTF8"
663 ++ " codepoint encountered"
664 )
665 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
666 0 -> error "unreachable state"
667 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
668 step' _ _ (InnerLoopDecoding st startf p end sv cp)
669 | p == end = do
670 liftIO $ touch startf
671 return $ Skip $ OuterLoop st (Just (sv, cp))
672 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
673 x <- liftIO $ peek p
674 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
675 return $
676 case sv of
677 0 ->
678 Skip $
679 YAndC
680 (unsafeChr cp)
681 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
682 12 ->
683 Skip $
684 transliterateOrError
685 (
686 "Streamly.Internal.Data.Stream.StreamD."
687 ++ "decodeUtf8ArraysWith: Invalid UTF8"
688 ++ " codepoint encountered"
689 )
690 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
691 _ ->
692 Skip
693 (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
694 step' _ _ (YAndC c s) = return $ Yield c s
695 step' _ _ D = return Stop
697{-# INLINE decodeUtf8ArraysD #-}
698decodeUtf8ArraysD ::
699 MonadIO m
700 => Stream m (A.Array Word8)
701 -> Stream m Char
702decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure
704-- |
705--
706-- /Pre-release/
707{-# INLINE decodeUtf8Arrays #-}
708decodeUtf8Arrays ::
709 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
710decodeUtf8Arrays =
711 fromStreamD . decodeUtf8ArraysD . toStreamD
713{-# INLINE decodeUtf8ArraysD' #-}
714decodeUtf8ArraysD' ::
715 MonadIO m
716 => Stream m (A.Array Word8)
717 -> Stream m Char
718decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure
720-- |
721--
722-- /Pre-release/
723{-# INLINE decodeUtf8Arrays' #-}
724decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
725decodeUtf8Arrays' = fromStreamD . decodeUtf8ArraysD' . toStreamD
727{-# INLINE decodeUtf8ArraysD_ #-}
728decodeUtf8ArraysD_ ::
729 MonadIO m
730 => Stream m (A.Array Word8)
731 -> Stream m Char
732decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure
734-- |
735--
736-- /Pre-release/
737{-# INLINE decodeUtf8Arrays_ #-}
738decodeUtf8Arrays_ ::
739 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
740decodeUtf8Arrays_ =
741 fromStreamD . decodeUtf8ArraysD_ . toStreamD
743-------------------------------------------------------------------------------
744-- Encoding Unicode (UTF-8) Characters
745-------------------------------------------------------------------------------
747data WList = WCons !Word8 !WList | WNil
749-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
751{-# INLINE ord2 #-}
752ord2 :: Char -> WList
753ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
754 where
755 n = ord c
756 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
757 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
759{-# INLINE ord3 #-}
760ord3 :: Char -> WList
761ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
762 where
763 n = ord c
764 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
765 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
766 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
768{-# INLINE ord4 #-}
769ord4 :: Char -> WList
770ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
771 where
772 n = ord c
773 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
774 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
775 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
776 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
778#ifndef __GHCJS__
779{-# ANN type EncodeState Fuse #-}
780#endif
781data EncodeState s = EncodeState s !WList
783#ifndef __GHCJS__
784{-# ANN type InvalidAction Fuse #-}
785#endif
786data InvalidAction =
787 DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid
789replaceInvalid :: s -> Step (EncodeState s) a
790replaceInvalid s =
791 Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil)))
793dropInvalid :: s -> Step (EncodeState s) a
794dropInvalid s = Skip (EncodeState s WNil)
796errorOnInvalid :: s -> Step (EncodeState s) a
797errorOnInvalid _ =
798 error $
799 show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:"
800 ++ "Encountered a surrogate"
802{-# INLINE_NORMAL encodeUtf8DGeneric #-}
803encodeUtf8DGeneric ::
804 Monad m
805 => InvalidAction
806 -> Stream m Char
807 -> Stream m Word8
808encodeUtf8DGeneric act (Stream step state) =
809 Stream step' (EncodeState state WNil)
811 where
813 {-# INLINE_LATE step' #-}
814 step' gst (EncodeState st WNil) = do
815 r <- step (adaptState gst) st
816 return $
817 case r of
818 Yield c s ->
819 case ord c of
820 x | x <= 0x7F ->
821 Yield (fromIntegral x) (EncodeState s WNil)
822 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
823 | x <= 0xFFFF ->
824 case act of
825 DropInvalid ->
826 if isSurrogate c
827 then dropInvalid s
828 else Skip (EncodeState s (ord3 c))
830 ErrorInvalid ->
831 if isSurrogate c
832 then errorOnInvalid s
833 else Skip (EncodeState s (ord3 c))
835 IgnoreInvalid ->
836 Skip (EncodeState s (ord3 c))
838 ReplaceInvalid ->
839 if isSurrogate c
840 then replaceInvalid s
841 else Skip (EncodeState s (ord3 c))
843 | otherwise -> Skip (EncodeState s (ord4 c))
844 Skip s -> Skip (EncodeState s WNil)
845 Stop -> Stop
846 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
848-- More yield points improve performance, but I am not sure if they can cause
849-- too much code bloat or some trouble with fusion. So keeping only two yield
850-- points for now, one for the ascii chars (fast path) and one for all other
851-- paths (slow path).
852{-# INLINE_NORMAL encodeUtf8D' #-}
853encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8
854encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid
856-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When
857-- any invalid character (U+D800-U+D8FF) is encountered in the input stream the
858-- function errors out.
859--
860-- @since 0.8.0
861{-# INLINE encodeUtf8' #-}
862encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8
863encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD
865-- | See section "3.9 Unicode Encoding Forms" in
866-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf
867--
868{-# INLINE_NORMAL encodeUtf8D #-}
869encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
870encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid
872-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
873-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the
874-- Unicode replacement character U+FFFD.
875--
876-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
877--
878-- /Since: 0.8.0 (Lenient Behaviour)/
879{-# INLINE encodeUtf8 #-}
880encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
881encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD
883{-# INLINE_NORMAL encodeUtf8D_ #-}
884encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8
885encodeUtf8D_ = encodeUtf8DGeneric DropInvalid
887-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
888-- Invalid characters (U+D800-U+D8FF) in the input stream are dropped.
889--
890-- @since 0.8.0
891{-# INLINE encodeUtf8_ #-}
892encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8
893encodeUtf8_ = fromStreamD . encodeUtf8D_ . toStreamD
895-- | Same as 'encodeUtf8'
896--
897{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}
898{-# INLINE encodeUtf8Lax #-}
899encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
900encodeUtf8Lax = encodeUtf8
902-------------------------------------------------------------------------------
903-- Encode streams of containers
904-------------------------------------------------------------------------------
906-- | Encode a container to @Array Word8@ provided an unfold to covert it to a
907-- Char stream and an encoding function.
908--
909-- /Internal/
910{-# INLINE encodeObject #-}
911encodeObject :: MonadIO m =>
912 (SerialT m Char -> SerialT m Word8)
913 -> Unfold m a Char
914 -> a
915 -> m (Array Word8)
916encodeObject encode u = S.fold Array.write . encode . S.unfold u
918-- | Encode a stream of container objects using the supplied encoding scheme.
919-- Each object is encoded as an @Array Word8@.
920--
921-- /Internal/
922{-# INLINE encodeObjects #-}
923encodeObjects :: (MonadIO m, IsStream t) =>
924 (SerialT m Char -> SerialT m Word8)
925 -> Unfold m a Char
926 -> t m a
927 -> t m (Array Word8)
928encodeObjects encode u = adapt . Serial.mapM (encodeObject encode u) . adapt
930-- | Encode a stream of 'String' using the supplied encoding scheme. Each
931-- string is encoded as an @Array Word8@.
932--
933-- @since 0.8.0
934{-# INLINE encodeStrings #-}
935encodeStrings :: (MonadIO m, IsStream t) =>
936 (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)
937encodeStrings encode = encodeObjects encode Unfold.fromList
939{-
940-------------------------------------------------------------------------------
941-- Utility operations on strings
942-------------------------------------------------------------------------------
944strip :: IsStream t => t m Char -> t m Char
945strip = undefined
947stripTail :: IsStream t => t m Char -> t m Char
948stripTail = undefined
949-}
951-- | Remove leading whitespace from a string.
952--
953-- > stripHead = S.dropWhile isSpace
954--
955-- /Pre-release/
956{-# INLINE stripHead #-}
957stripHead :: (Monad m, IsStream t) => t m Char -> t m Char
958stripHead = S.dropWhile isSpace
960-- | Fold each line of the stream using the supplied 'Fold'
961-- and stream the result.
962--
963-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")
964-- ["lines","this","string","",""]
965--
966-- > lines = S.splitOnSuffix (== '\n')
967--
968-- /Pre-release/
969{-# INLINE lines #-}
970lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
971lines = S.splitOnSuffix (== '\n')
973foreign import ccall unsafe "u_iswspace"
974 iswspace :: Int -> Int
976-- | Code copied from base/Data.Char to INLINE it
977{-# INLINE isSpace #-}
978isSpace :: Char -> Bool
979isSpace c
980 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0
981 | otherwise = iswspace (ord c) /= 0
982 where
983 uc = fromIntegral (ord c) :: Word
985-- | Fold each word of the stream using the supplied 'Fold'
986-- and stream the result.
987--
988-- >>> Stream.toList $ words Fold.toList (Stream.fromList "fold these words")
989-- ["fold","these","words"]
990--
991-- > words = S.wordsBy isSpace
992--
993-- /Pre-release/
994{-# INLINE words #-}
995words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
996words = S.wordsBy isSpace
998-- | Unfold a stream to character streams using the supplied 'Unfold'
999-- and concat the results suffixing a newline character @\\n@ to each stream.
1001-- @
1002-- unlines = Stream.interposeSuffix '\n'
1003-- unlines = Stream.intercalateSuffix Unfold.fromList "\n"
1004-- @
1006-- /Pre-release/
1007{-# INLINE unlines #-}
1008unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1009unlines = S.interposeSuffix '\n'
1011-- | Unfold the elements of a stream to character streams using the supplied
1012-- 'Unfold' and concat the results with a whitespace character infixed between
1013-- the streams.
1015-- @
1016-- unwords = Stream.interpose ' '
1017-- unwords = Stream.intercalate Unfold.fromList " "
1018-- @
1020-- /Pre-release/
1021{-# INLINE unwords #-}
1022unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1023unwords = S.interpose ' '