git.iko.soy/streamly
on 0cbcf0b help sign in
streamly/src/Streamly/Internal/Unicode/Stream.hs
1020 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.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 = A.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 !(Ptr addr) = table
260 end = table `plusPtr` 364
261 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
262 showByte = "Streamly: decode0: byte: " ++ show byte
263 showTable = " table: " ++ show utf8table
265-- When the state is not 0
266{-# INLINE decode1 #-}
267decode1
268 :: Ptr Word8
269 -> DecodeState
270 -> CodePoint
271 -> Word8
272 -> Tuple' DecodeState CodePoint
273decode1 table state codep byte =
274 -- Remember codep is Int type!
275 -- Can it be unsafe to convert the resulting Int to Char?
276 let !t = table `unsafePeekElemOff` fromIntegral byte
277 !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
278 !state' = table `unsafePeekElemOff`
279 (256 + fromIntegral state + fromIntegral t)
280 in assert (codep' <= 0x10FFFF
281 || error (showByte ++ showState state codep))
282 (Tuple' state' codep')
283 where
285 utf8table =
286 let !(Ptr addr) = table
287 end = table `plusPtr` 364
288 in A.Array (ForeignPtr addr undefined) end :: A.Array Word8
289 showByte = "Streamly: decode1: byte: " ++ show byte
290 showState st cp =
291 " state: " ++ show st ++
292 " codepoint: " ++ show cp ++
293 " table: " ++ show utf8table
295-------------------------------------------------------------------------------
296-- Resumable UTF-8 decoding
297-------------------------------------------------------------------------------
299{-# ANN type UTF8DecodeState Fuse #-}
300data UTF8DecodeState s a
301 = UTF8DecodeInit s
302 | UTF8DecodeInit1 s Word8
303 | UTF8DecodeFirst s Word8
304 | UTF8Decoding s !DecodeState !CodePoint
305 | YieldAndContinue a (UTF8DecodeState s a)
306 | Done
308{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}
309resumeDecodeUtf8EitherD
310 :: Monad m
311 => DecodeState
312 -> CodePoint
313 -> Stream m Word8
314 -> Stream m (Either DecodeError Char)
315resumeDecodeUtf8EitherD dst codep (Stream step state) =
316 let A.Array p _ = utf8d
317 !ptr = unsafeForeignPtrToPtr p
318 stt =
319 if dst == 0
320 then UTF8DecodeInit state
321 else UTF8Decoding state dst codep
322 in Stream (step' ptr) stt
323 where
324 {-# INLINE_LATE step' #-}
325 step' _ gst (UTF8DecodeInit st) = do
326 r <- step (adaptState gst) st
327 return $ case r of
328 Yield x s -> Skip (UTF8DecodeInit1 s x)
329 Skip s -> Skip (UTF8DecodeInit s)
330 Stop -> Skip Done
332 step' _ _ (UTF8DecodeInit1 st x) = do
333 -- Note: It is important to use a ">" instead of a "<=" test
334 -- here for GHC to generate code layout for default branch
335 -- prediction for the common case. This is fragile and might
336 -- change with the compiler versions, we need a more reliable
337 -- "likely" primitive to control branch predication.
338 case x > 0x7f of
339 False ->
340 return $ Skip $ YieldAndContinue
341 (Right $ unsafeChr (fromIntegral x))
342 (UTF8DecodeInit st)
343 -- Using a separate state here generates a jump to a
344 -- separate code block in the core which seems to perform
345 -- slightly better for the non-ascii case.
346 True -> return $ Skip $ UTF8DecodeFirst st x
348 -- XXX should we merge it with UTF8DecodeInit1?
349 step' table _ (UTF8DecodeFirst st x) = do
350 let (Tuple' sv cp) = decode0 table x
351 return $
352 case sv of
353 12 ->
354 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
355 (UTF8DecodeInit st)
356 0 -> error "unreachable state"
357 _ -> Skip (UTF8Decoding st sv cp)
359 -- We recover by trying the new byte x a starter of a new codepoint.
360 -- XXX on error need to report the next byte "x" as well.
361 -- XXX need to use the same recovery in array decoding routine as well
362 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
363 r <- step (adaptState gst) st
364 case r of
365 Yield x s -> do
366 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
367 return $
368 case sv of
369 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
370 (UTF8DecodeInit s)
371 12 ->
372 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
373 (UTF8DecodeInit1 s x)
374 _ -> Skip (UTF8Decoding s sv cp)
375 Skip s -> return $ Skip (UTF8Decoding s statePtr codepointPtr)
376 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
378 step' _ _ (YieldAndContinue c s) = return $ Yield c s
379 step' _ _ Done = return Stop
381-- XXX We can use just one API, and define InitState = 0 and InitCodePoint = 0
382-- to use as starting state.
383--
384{-# INLINE_NORMAL decodeUtf8EitherD #-}
385decodeUtf8EitherD :: Monad m
386 => Stream m Word8 -> Stream m (Either DecodeError Char)
387decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0
389-- |
390--
391-- /Pre-release/
392{-# INLINE decodeUtf8Either #-}
393decodeUtf8Either :: (Monad m, IsStream t)
394 => t m Word8 -> t m (Either DecodeError Char)
395decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD
397-- |
398--
399-- /Pre-release/
400{-# INLINE resumeDecodeUtf8Either #-}
401resumeDecodeUtf8Either
402 :: (Monad m, IsStream t)
403 => DecodeState
404 -> CodePoint
405 -> t m Word8
406 -> t m (Either DecodeError Char)
407resumeDecodeUtf8Either st cp =
408 D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD
410-------------------------------------------------------------------------------
411-- One shot decoding
412-------------------------------------------------------------------------------
414data CodingFailureMode
415 = TransliterateCodingFailure
416 | ErrorOnCodingFailure
417 | DropOnCodingFailure
418 deriving (Show)
420{-# INLINE replacementChar #-}
421replacementChar :: Char
422replacementChar = '\xFFFD'
424-- XXX write it as a parser and use parseMany to decode a stream, need to check
425-- if that preserves the same performance. Or we can use a resumable parser
426-- that parses a chunk at a time.
427--
428-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that
429-- decodeUtf8Either preserves the performance characterstics.
430--
431{-# INLINE_NORMAL decodeUtf8WithD #-}
432decodeUtf8WithD :: Monad m
433 => CodingFailureMode -> Stream m Word8 -> Stream m Char
434decodeUtf8WithD cfm (Stream step state) =
435 let A.Array p _ = utf8d
436 !ptr = unsafeForeignPtrToPtr p
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 = D.fromStreamD . decodeUtf8D . D.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' = D.fromStreamD . decodeUtf8D' . D.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_ = D.fromStreamD . decodeUtf8D_ . D.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{-# ANN type FlattenState Fuse #-}
570data FlattenState s a
571 = OuterLoop s !(Maybe (DecodeState, CodePoint))
572 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
573 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
574 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
575 !DecodeState !CodePoint
576 | YAndC !Char (FlattenState s a) -- These constructors can be
577 -- encoded in the UTF8DecodeState
578 -- type, I prefer to keep these
579 -- flat even though that means
580 -- coming up with new names
581 | D
583-- The normal decodeUtf8 above should fuse with flattenArrays
584-- to create this exact code but it doesn't for some reason, as of now this
585-- remains the fastest way I could figure out to decodeUtf8.
586--
587-- XXX Add Proper error messages
588{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
589decodeUtf8ArraysWithD ::
590 MonadIO m
591 => CodingFailureMode
592 -> Stream m (A.Array Word8)
593 -> Stream m Char
594decodeUtf8ArraysWithD cfm (Stream step state) =
595 let A.Array p _ = utf8d
596 !ptr = unsafeForeignPtrToPtr p
597 in Stream (step' ptr) (OuterLoop state Nothing)
598 where
599 {-# INLINE transliterateOrError #-}
600 transliterateOrError e s =
601 case cfm of
602 ErrorOnCodingFailure -> error e
603 TransliterateCodingFailure -> YAndC replacementChar s
604 DropOnCodingFailure -> s
605 {-# INLINE inputUnderflow #-}
606 inputUnderflow =
607 case cfm of
608 ErrorOnCodingFailure ->
609 error $
610 show "Streamly.Internal.Data.Stream.StreamD."
611 ++ "decodeUtf8ArraysWith: Input Underflow"
612 TransliterateCodingFailure -> YAndC replacementChar D
613 DropOnCodingFailure -> D
614 {-# INLINE_LATE step' #-}
615 step' _ gst (OuterLoop st Nothing) = do
616 r <- step (adaptState gst) st
617 return $
618 case r of
619 Yield A.Array {..} s ->
620 let p = unsafeForeignPtrToPtr aStart
621 in Skip (InnerLoopDecodeInit s aStart p 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 let p = unsafeForeignPtrToPtr aStart
630 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
631 Skip s -> Skip (OuterLoop s dst)
632 Stop -> Skip inputUnderflow
633 step' _ _ (InnerLoopDecodeInit st startf p end)
634 | p == end = do
635 liftIO $ touchForeignPtr startf
636 return $ Skip $ OuterLoop st Nothing
637 step' _ _ (InnerLoopDecodeInit st startf p end) = do
638 x <- liftIO $ peek p
639 -- Note: It is important to use a ">" instead of a "<=" test here for
640 -- GHC to generate code layout for default branch prediction for the
641 -- common case. This is fragile and might change with the compiler
642 -- versions, we need a more reliable "likely" primitive to control
643 -- branch predication.
644 case x > 0x7f of
645 False ->
646 return $ Skip $ YAndC
647 (unsafeChr (fromIntegral x))
648 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
649 -- Using a separate state here generates a jump to a separate code
650 -- block in the core which seems to perform slightly better for the
651 -- non-ascii case.
652 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
654 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
655 let (Tuple' sv cp) = decode0 table x
656 return $
657 case sv of
658 12 ->
659 Skip $
660 transliterateOrError
661 (
662 "Streamly.Internal.Data.Stream.StreamD."
663 ++ "decodeUtf8ArraysWith: Invalid UTF8"
664 ++ " codepoint encountered"
665 )
666 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
667 0 -> error "unreachable state"
668 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
669 step' _ _ (InnerLoopDecoding st startf p end sv cp)
670 | p == end = do
671 liftIO $ touchForeignPtr startf
672 return $ Skip $ OuterLoop st (Just (sv, cp))
673 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
674 x <- liftIO $ peek p
675 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
676 return $
677 case sv of
678 0 ->
679 Skip $
680 YAndC
681 (unsafeChr cp)
682 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
683 12 ->
684 Skip $
685 transliterateOrError
686 (
687 "Streamly.Internal.Data.Stream.StreamD."
688 ++ "decodeUtf8ArraysWith: Invalid UTF8"
689 ++ " codepoint encountered"
690 )
691 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
692 _ ->
693 Skip
694 (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
695 step' _ _ (YAndC c s) = return $ Yield c s
696 step' _ _ D = return Stop
698{-# INLINE decodeUtf8ArraysD #-}
699decodeUtf8ArraysD ::
700 MonadIO m
701 => Stream m (A.Array Word8)
702 -> Stream m Char
703decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure
705-- |
706--
707-- /Pre-release/
708{-# INLINE decodeUtf8Arrays #-}
709decodeUtf8Arrays ::
710 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
711decodeUtf8Arrays =
712 D.fromStreamD . decodeUtf8ArraysD . D.toStreamD
714{-# INLINE decodeUtf8ArraysD' #-}
715decodeUtf8ArraysD' ::
716 MonadIO m
717 => Stream m (A.Array Word8)
718 -> Stream m Char
719decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure
721-- |
722--
723-- /Pre-release/
724{-# INLINE decodeUtf8Arrays' #-}
725decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
726decodeUtf8Arrays' = D.fromStreamD . decodeUtf8ArraysD' . D.toStreamD
728{-# INLINE decodeUtf8ArraysD_ #-}
729decodeUtf8ArraysD_ ::
730 MonadIO m
731 => Stream m (A.Array Word8)
732 -> Stream m Char
733decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure
735-- |
736--
737-- /Pre-release/
738{-# INLINE decodeUtf8Arrays_ #-}
739decodeUtf8Arrays_ ::
740 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
741decodeUtf8Arrays_ =
742 D.fromStreamD . decodeUtf8ArraysD_ . D.toStreamD
744-------------------------------------------------------------------------------
745-- Encoding Unicode (UTF-8) Characters
746-------------------------------------------------------------------------------
748data WList = WCons !Word8 !WList | WNil
750-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
752{-# INLINE ord2 #-}
753ord2 :: Char -> WList
754ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
755 where
756 n = ord c
757 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
758 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
760{-# INLINE ord3 #-}
761ord3 :: Char -> WList
762ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
763 where
764 n = ord c
765 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
766 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
767 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
769{-# INLINE ord4 #-}
770ord4 :: Char -> WList
771ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
772 where
773 n = ord c
774 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
775 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
776 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
777 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
779{-# ANN type EncodeState Fuse #-}
780data EncodeState s = EncodeState s !WList
782{-# ANN type InvalidAction Fuse #-}
783data InvalidAction =
784 DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid
786replaceInvalid :: s -> Step (EncodeState s) a
787replaceInvalid s =
788 Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil)))
790dropInvalid :: s -> Step (EncodeState s) a
791dropInvalid s = Skip (EncodeState s WNil)
793errorOnInvalid :: s -> Step (EncodeState s) a
794errorOnInvalid _ =
795 error $
796 show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:"
797 ++ "Encountered a surrogate"
799{-# INLINE_NORMAL encodeUtf8DGeneric #-}
800encodeUtf8DGeneric ::
801 Monad m
802 => InvalidAction
803 -> Stream m Char
804 -> Stream m Word8
805encodeUtf8DGeneric act (Stream step state) =
806 Stream step' (EncodeState state WNil)
808 where
810 {-# INLINE_LATE step' #-}
811 step' gst (EncodeState st WNil) = do
812 r <- step (adaptState gst) st
813 return $
814 case r of
815 Yield c s ->
816 case ord c of
817 x | x <= 0x7F ->
818 Yield (fromIntegral x) (EncodeState s WNil)
819 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
820 | x <= 0xFFFF ->
821 case act of
822 DropInvalid ->
823 if isSurrogate c
824 then dropInvalid s
825 else Skip (EncodeState s (ord3 c))
827 ErrorInvalid ->
828 if isSurrogate c
829 then errorOnInvalid s
830 else Skip (EncodeState s (ord3 c))
832 IgnoreInvalid ->
833 Skip (EncodeState s (ord3 c))
835 ReplaceInvalid ->
836 if isSurrogate c
837 then replaceInvalid s
838 else Skip (EncodeState s (ord3 c))
840 | otherwise -> Skip (EncodeState s (ord4 c))
841 Skip s -> Skip (EncodeState s WNil)
842 Stop -> Stop
843 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
845-- More yield points improve performance, but I am not sure if they can cause
846-- too much code bloat or some trouble with fusion. So keeping only two yield
847-- points for now, one for the ascii chars (fast path) and one for all other
848-- paths (slow path).
849{-# INLINE_NORMAL encodeUtf8D' #-}
850encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8
851encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid
853-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When
854-- any invalid character (U+D800-U+D8FF) is encountered in the input stream the
855-- function errors out.
856--
857-- @since 0.8.0
858{-# INLINE encodeUtf8' #-}
859encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8
860encodeUtf8' = D.fromStreamD . encodeUtf8D' . D.toStreamD
862-- | See section "3.9 Unicode Encoding Forms" in
863-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf
864--
865{-# INLINE_NORMAL encodeUtf8D #-}
866encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
867encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid
869-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
870-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the
871-- Unicode replacement character U+FFFD.
872--
873-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
874--
875-- /Since: 0.8.0 (Lenient Behaviour)/
876{-# INLINE encodeUtf8 #-}
877encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
878encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD
880{-# INLINE_NORMAL encodeUtf8D_ #-}
881encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8
882encodeUtf8D_ = encodeUtf8DGeneric DropInvalid
884-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
885-- Invalid characters (U+D800-U+D8FF) in the input stream are dropped.
886--
887-- @since 0.8.0
888{-# INLINE encodeUtf8_ #-}
889encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8
890encodeUtf8_ = D.fromStreamD . encodeUtf8D_ . D.toStreamD
892-- | Same as 'encodeUtf8'
893--
894{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}
895{-# INLINE encodeUtf8Lax #-}
896encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
897encodeUtf8Lax = encodeUtf8
899-------------------------------------------------------------------------------
900-- Encode streams of containers
901-------------------------------------------------------------------------------
903-- | Encode a container to @Array Word8@ provided an unfold to covert it to a
904-- Char stream and an encoding function.
905--
906-- /Internal/
907{-# INLINE encodeObject #-}
908encodeObject :: MonadIO m =>
909 (SerialT m Char -> SerialT m Word8)
910 -> Unfold m a Char
911 -> a
912 -> m (Array Word8)
913encodeObject encode u = S.fold Array.write . encode . S.unfold u
915-- | Encode a stream of container objects using the supplied encoding scheme.
916-- Each object is encoded as an @Array Word8@.
917--
918-- /Internal/
919{-# INLINE encodeObjects #-}
920encodeObjects :: (MonadIO m, IsStream t) =>
921 (SerialT m Char -> SerialT m Word8)
922 -> Unfold m a Char
923 -> t m a
924 -> t m (Array Word8)
925encodeObjects encode u = Serial.mapM (encodeObject encode u)
927-- | Encode a stream of 'String' using the supplied encoding scheme. Each
928-- string is encoded as an @Array Word8@.
929--
930-- @since 0.8.0
931{-# INLINE encodeStrings #-}
932encodeStrings :: (MonadIO m, IsStream t) =>
933 (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)
934encodeStrings encode = encodeObjects encode Unfold.fromList
936{-
937-------------------------------------------------------------------------------
938-- Utility operations on strings
939-------------------------------------------------------------------------------
941strip :: IsStream t => t m Char -> t m Char
942strip = undefined
944stripTail :: IsStream t => t m Char -> t m Char
945stripTail = undefined
946-}
948-- | Remove leading whitespace from a string.
949--
950-- > stripHead = S.dropWhile isSpace
951--
952-- /Pre-release/
953{-# INLINE stripHead #-}
954stripHead :: (Monad m, IsStream t) => t m Char -> t m Char
955stripHead = S.dropWhile isSpace
957-- | Fold each line of the stream using the supplied 'Fold'
958-- and stream the result.
959--
960-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")
961-- ["lines","this","string","",""]
962--
963-- > lines = S.splitOnSuffix (== '\n')
964--
965-- /Pre-release/
966{-# INLINE lines #-}
967lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
968lines = S.splitOnSuffix (== '\n')
970foreign import ccall unsafe "u_iswspace"
971 iswspace :: Int -> Int
973-- | Code copied from base/Data.Char to INLINE it
974{-# INLINE isSpace #-}
975isSpace :: Char -> Bool
976isSpace c
977 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0
978 | otherwise = iswspace (ord c) /= 0
979 where
980 uc = fromIntegral (ord c) :: Word
982-- | Fold each word of the stream using the supplied 'Fold'
983-- and stream the result.
984--
985-- >>> Stream.toList $ words Fold.toList (Stream.fromList "fold these words")
986-- ["fold","these","words"]
987--
988-- > words = S.wordsBy isSpace
989--
990-- /Pre-release/
991{-# INLINE words #-}
992words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
993words = S.wordsBy isSpace
995-- | Unfold a stream to character streams using the supplied 'Unfold'
996-- and concat the results suffixing a newline character @\\n@ to each stream.
997--
998-- @
999-- unlines = Stream.interposeSuffix '\n'
1000-- unlines = Stream.intercalateSuffix Unfold.fromList "\n"
1001-- @
1003-- /Pre-release/
1004{-# INLINE unlines #-}
1005unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1006unlines = S.interposeSuffix '\n'
1008-- | Unfold the elements of a stream to character streams using the supplied
1009-- 'Unfold' and concat the results with a whitespace character infixed between
1010-- the streams.
1012-- @
1013-- unwords = Stream.interpose ' '
1014-- unwords = Stream.intercalate Unfold.fromList " "
1015-- @
1017-- /Pre-release/
1018{-# INLINE unwords #-}
1019unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1020unwords = S.interpose ' '