git.iko.soy/streamly
on 705d2cf help sign in
streamly/src/Streamly/Internal/Unicode/Stream.hs
1030 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-- Strangely, GHCJS hangs linking template-haskell with this
301#ifndef __GHCJS__
302{-# ANN type UTF8DecodeState Fuse #-}
303#endif
304data UTF8DecodeState s a
305 = UTF8DecodeInit s
306 | UTF8DecodeInit1 s Word8
307 | UTF8DecodeFirst s Word8
308 | UTF8Decoding s !DecodeState !CodePoint
309 | YieldAndContinue a (UTF8DecodeState s a)
310 | Done
312{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}
313resumeDecodeUtf8EitherD
314 :: Monad m
315 => DecodeState
316 -> CodePoint
317 -> Stream m Word8
318 -> Stream m (Either DecodeError Char)
319resumeDecodeUtf8EitherD dst codep (Stream step state) =
320 let A.Array p _ = utf8d
321 !ptr = unsafeForeignPtrToPtr p
322 stt =
323 if dst == 0
324 then UTF8DecodeInit state
325 else UTF8Decoding state dst codep
326 in Stream (step' ptr) stt
327 where
328 {-# INLINE_LATE step' #-}
329 step' _ gst (UTF8DecodeInit st) = do
330 r <- step (adaptState gst) st
331 return $ case r of
332 Yield x s -> Skip (UTF8DecodeInit1 s x)
333 Skip s -> Skip (UTF8DecodeInit s)
334 Stop -> Skip Done
336 step' _ _ (UTF8DecodeInit1 st x) = do
337 -- Note: It is important to use a ">" instead of a "<=" test
338 -- here for GHC to generate code layout for default branch
339 -- prediction for the common case. This is fragile and might
340 -- change with the compiler versions, we need a more reliable
341 -- "likely" primitive to control branch predication.
342 case x > 0x7f of
343 False ->
344 return $ Skip $ YieldAndContinue
345 (Right $ unsafeChr (fromIntegral x))
346 (UTF8DecodeInit st)
347 -- Using a separate state here generates a jump to a
348 -- separate code block in the core which seems to perform
349 -- slightly better for the non-ascii case.
350 True -> return $ Skip $ UTF8DecodeFirst st x
352 -- XXX should we merge it with UTF8DecodeInit1?
353 step' table _ (UTF8DecodeFirst st x) = do
354 let (Tuple' sv cp) = decode0 table x
355 return $
356 case sv of
357 12 ->
358 Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
359 (UTF8DecodeInit st)
360 0 -> error "unreachable state"
361 _ -> Skip (UTF8Decoding st sv cp)
363 -- We recover by trying the new byte x a starter of a new codepoint.
364 -- XXX on error need to report the next byte "x" as well.
365 -- XXX need to use the same recovery in array decoding routine as well
366 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
367 r <- step (adaptState gst) st
368 case r of
369 Yield x s -> do
370 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
371 return $
372 case sv of
373 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
374 (UTF8DecodeInit s)
375 12 ->
376 Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
377 (UTF8DecodeInit1 s x)
378 _ -> Skip (UTF8Decoding s sv cp)
379 Skip s -> return $ Skip (UTF8Decoding s statePtr codepointPtr)
380 Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
382 step' _ _ (YieldAndContinue c s) = return $ Yield c s
383 step' _ _ Done = return Stop
385-- XXX We can use just one API, and define InitState = 0 and InitCodePoint = 0
386-- to use as starting state.
387--
388{-# INLINE_NORMAL decodeUtf8EitherD #-}
389decodeUtf8EitherD :: Monad m
390 => Stream m Word8 -> Stream m (Either DecodeError Char)
391decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0
393-- |
394--
395-- /Pre-release/
396{-# INLINE decodeUtf8Either #-}
397decodeUtf8Either :: (Monad m, IsStream t)
398 => t m Word8 -> t m (Either DecodeError Char)
399decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD
401-- |
402--
403-- /Pre-release/
404{-# INLINE resumeDecodeUtf8Either #-}
405resumeDecodeUtf8Either
406 :: (Monad m, IsStream t)
407 => DecodeState
408 -> CodePoint
409 -> t m Word8
410 -> t m (Either DecodeError Char)
411resumeDecodeUtf8Either st cp =
412 D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD
414-------------------------------------------------------------------------------
415-- One shot decoding
416-------------------------------------------------------------------------------
418data CodingFailureMode
419 = TransliterateCodingFailure
420 | ErrorOnCodingFailure
421 | DropOnCodingFailure
422 deriving (Show)
424{-# INLINE replacementChar #-}
425replacementChar :: Char
426replacementChar = '\xFFFD'
428-- XXX write it as a parser and use parseMany to decode a stream, need to check
429-- if that preserves the same performance. Or we can use a resumable parser
430-- that parses a chunk at a time.
431--
432-- XXX Implement this in terms of decodeUtf8Either. Need to make sure that
433-- decodeUtf8Either preserves the performance characterstics.
434--
435{-# INLINE_NORMAL decodeUtf8WithD #-}
436decodeUtf8WithD :: Monad m
437 => CodingFailureMode -> Stream m Word8 -> Stream m Char
438decodeUtf8WithD cfm (Stream step state) =
439 let A.Array p _ = utf8d
440 !ptr = unsafeForeignPtrToPtr p
441 in Stream (step' ptr) (UTF8DecodeInit state)
443 where
445 prefix = "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: "
447 {-# INLINE handleError #-}
448 handleError e s =
449 case cfm of
450 ErrorOnCodingFailure -> error e
451 TransliterateCodingFailure -> YieldAndContinue replacementChar s
452 DropOnCodingFailure -> s
454 {-# INLINE handleUnderflow #-}
455 handleUnderflow =
456 case cfm of
457 ErrorOnCodingFailure -> error $ prefix ++ "Not enough input"
458 TransliterateCodingFailure -> YieldAndContinue replacementChar Done
459 DropOnCodingFailure -> Done
461 {-# INLINE_LATE step' #-}
462 step' _ gst (UTF8DecodeInit st) = do
463 r <- step (adaptState gst) st
464 return $ case r of
465 Yield x s -> Skip (UTF8DecodeInit1 s x)
466 Skip s -> Skip (UTF8DecodeInit s)
467 Stop -> Skip Done
469 step' _ _ (UTF8DecodeInit1 st x) = do
470 -- Note: It is important to use a ">" instead of a "<=" test
471 -- here for GHC to generate code layout for default branch
472 -- prediction for the common case. This is fragile and might
473 -- change with the compiler versions, we need a more reliable
474 -- "likely" primitive to control branch predication.
475 case x > 0x7f of
476 False ->
477 return $ Skip $ YieldAndContinue
478 (unsafeChr (fromIntegral x))
479 (UTF8DecodeInit st)
480 -- Using a separate state here generates a jump to a
481 -- separate code block in the core which seems to perform
482 -- slightly better for the non-ascii case.
483 True -> return $ Skip $ UTF8DecodeFirst st x
485 -- XXX should we merge it with UTF8DecodeInit1?
486 step' table _ (UTF8DecodeFirst st x) = do
487 let (Tuple' sv cp) = decode0 table x
488 return $
489 case sv of
490 12 ->
491 let msg = prefix ++ "Invalid first UTF8 byte " ++ show x
492 in Skip $ handleError msg (UTF8DecodeInit st)
493 0 -> error "unreachable state"
494 _ -> Skip (UTF8Decoding st sv cp)
496 -- We recover by trying the new byte x as a starter of a new codepoint.
497 -- XXX need to use the same recovery in array decoding routine as well
498 step' table gst (UTF8Decoding st statePtr codepointPtr) = do
499 r <- step (adaptState gst) st
500 case r of
501 Yield x s -> do
502 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
503 return $ case sv of
504 0 -> Skip $ YieldAndContinue
505 (unsafeChr cp) (UTF8DecodeInit s)
506 12 ->
507 let msg = prefix
508 ++ "Invalid subsequent UTF8 byte "
509 ++ show x
510 ++ " in state "
511 ++ show statePtr
512 ++ " accumulated value "
513 ++ show codepointPtr
514 in Skip $ handleError msg (UTF8DecodeInit1 s x)
515 _ -> Skip (UTF8Decoding s sv cp)
516 Skip s -> return $
517 Skip (UTF8Decoding s statePtr codepointPtr)
518 Stop -> return $ Skip handleUnderflow
520 step' _ _ (YieldAndContinue c s) = return $ Yield c s
521 step' _ _ Done = return Stop
523{-# INLINE decodeUtf8D #-}
524decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char
525decodeUtf8D = decodeUtf8WithD TransliterateCodingFailure
527-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
528-- Any invalid codepoint encountered is replaced with the unicode replacement
529-- character.
530--
531-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
532--
533-- /Since: 0.8.0 (Lenient Behaviour)/
534{-# INLINE decodeUtf8 #-}
535decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char
536decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD
538{-# INLINE decodeUtf8D' #-}
539decodeUtf8D' :: Monad m => Stream m Word8 -> Stream m Char
540decodeUtf8D' = decodeUtf8WithD ErrorOnCodingFailure
542-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
543-- The function throws an error if an invalid codepoint is encountered.
544--
545-- @since 0.8.0
546{-# INLINE decodeUtf8' #-}
547decodeUtf8' :: (Monad m, IsStream t) => t m Word8 -> t m Char
548decodeUtf8' = D.fromStreamD . decodeUtf8D' . D.toStreamD
550{-# INLINE decodeUtf8D_ #-}
551decodeUtf8D_ :: Monad m => Stream m Word8 -> Stream m Char
552decodeUtf8D_ = decodeUtf8WithD DropOnCodingFailure
554-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
555-- Any invalid codepoint encountered is dropped.
556--
557-- @since 0.8.0
558{-# INLINE decodeUtf8_ #-}
559decodeUtf8_ :: (Monad m, IsStream t) => t m Word8 -> t m Char
560decodeUtf8_ = D.fromStreamD . decodeUtf8D_ . D.toStreamD
562-- | Same as 'decodeUtf8'
563--
564{-# DEPRECATED decodeUtf8Lax "Please use 'decodeUtf8' instead" #-}
565{-# INLINE decodeUtf8Lax #-}
566decodeUtf8Lax :: (IsStream t, Monad m) => t m Word8 -> t m Char
567decodeUtf8Lax = decodeUtf8
569-------------------------------------------------------------------------------
570-- Decoding Array Streams
571-------------------------------------------------------------------------------
573#ifndef __GHCJS__
574{-# ANN type FlattenState Fuse #-}
575#endif
576data FlattenState s a
577 = OuterLoop s !(Maybe (DecodeState, CodePoint))
578 | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
579 | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
580 | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
581 !DecodeState !CodePoint
582 | YAndC !Char (FlattenState s a) -- These constructors can be
583 -- encoded in the UTF8DecodeState
584 -- type, I prefer to keep these
585 -- flat even though that means
586 -- coming up with new names
587 | D
589-- The normal decodeUtf8 above should fuse with flattenArrays
590-- to create this exact code but it doesn't for some reason, as of now this
591-- remains the fastest way I could figure out to decodeUtf8.
592--
593-- XXX Add Proper error messages
594{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
595decodeUtf8ArraysWithD ::
596 MonadIO m
597 => CodingFailureMode
598 -> Stream m (A.Array Word8)
599 -> Stream m Char
600decodeUtf8ArraysWithD cfm (Stream step state) =
601 let A.Array p _ = utf8d
602 !ptr = unsafeForeignPtrToPtr p
603 in Stream (step' ptr) (OuterLoop state Nothing)
604 where
605 {-# INLINE transliterateOrError #-}
606 transliterateOrError e s =
607 case cfm of
608 ErrorOnCodingFailure -> error e
609 TransliterateCodingFailure -> YAndC replacementChar s
610 DropOnCodingFailure -> s
611 {-# INLINE inputUnderflow #-}
612 inputUnderflow =
613 case cfm of
614 ErrorOnCodingFailure ->
615 error $
616 show "Streamly.Internal.Data.Stream.StreamD."
617 ++ "decodeUtf8ArraysWith: Input Underflow"
618 TransliterateCodingFailure -> YAndC replacementChar D
619 DropOnCodingFailure -> D
620 {-# INLINE_LATE step' #-}
621 step' _ gst (OuterLoop st Nothing) = do
622 r <- step (adaptState gst) st
623 return $
624 case r of
625 Yield A.Array {..} s ->
626 let p = unsafeForeignPtrToPtr aStart
627 in Skip (InnerLoopDecodeInit s aStart p aEnd)
628 Skip s -> Skip (OuterLoop s Nothing)
629 Stop -> Skip D
630 step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
631 r <- step (adaptState gst) st
632 return $
633 case r of
634 Yield A.Array {..} s ->
635 let p = unsafeForeignPtrToPtr aStart
636 in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
637 Skip s -> Skip (OuterLoop s dst)
638 Stop -> Skip inputUnderflow
639 step' _ _ (InnerLoopDecodeInit st startf p end)
640 | p == end = do
641 liftIO $ touchForeignPtr startf
642 return $ Skip $ OuterLoop st Nothing
643 step' _ _ (InnerLoopDecodeInit st startf p end) = do
644 x <- liftIO $ peek p
645 -- Note: It is important to use a ">" instead of a "<=" test here for
646 -- GHC to generate code layout for default branch prediction for the
647 -- common case. This is fragile and might change with the compiler
648 -- versions, we need a more reliable "likely" primitive to control
649 -- branch predication.
650 case x > 0x7f of
651 False ->
652 return $ Skip $ YAndC
653 (unsafeChr (fromIntegral x))
654 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
655 -- Using a separate state here generates a jump to a separate code
656 -- block in the core which seems to perform slightly better for the
657 -- non-ascii case.
658 True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
660 step' table _ (InnerLoopDecodeFirst st startf p end x) = do
661 let (Tuple' sv cp) = decode0 table x
662 return $
663 case sv of
664 12 ->
665 Skip $
666 transliterateOrError
667 (
668 "Streamly.Internal.Data.Stream.StreamD."
669 ++ "decodeUtf8ArraysWith: Invalid UTF8"
670 ++ " codepoint encountered"
671 )
672 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
673 0 -> error "unreachable state"
674 _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
675 step' _ _ (InnerLoopDecoding st startf p end sv cp)
676 | p == end = do
677 liftIO $ touchForeignPtr startf
678 return $ Skip $ OuterLoop st (Just (sv, cp))
679 step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
680 x <- liftIO $ peek p
681 let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
682 return $
683 case sv of
684 0 ->
685 Skip $
686 YAndC
687 (unsafeChr cp)
688 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
689 12 ->
690 Skip $
691 transliterateOrError
692 (
693 "Streamly.Internal.Data.Stream.StreamD."
694 ++ "decodeUtf8ArraysWith: Invalid UTF8"
695 ++ " codepoint encountered"
696 )
697 (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
698 _ ->
699 Skip
700 (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
701 step' _ _ (YAndC c s) = return $ Yield c s
702 step' _ _ D = return Stop
704{-# INLINE decodeUtf8ArraysD #-}
705decodeUtf8ArraysD ::
706 MonadIO m
707 => Stream m (A.Array Word8)
708 -> Stream m Char
709decodeUtf8ArraysD = decodeUtf8ArraysWithD TransliterateCodingFailure
711-- |
712--
713-- /Pre-release/
714{-# INLINE decodeUtf8Arrays #-}
715decodeUtf8Arrays ::
716 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
717decodeUtf8Arrays =
718 D.fromStreamD . decodeUtf8ArraysD . D.toStreamD
720{-# INLINE decodeUtf8ArraysD' #-}
721decodeUtf8ArraysD' ::
722 MonadIO m
723 => Stream m (A.Array Word8)
724 -> Stream m Char
725decodeUtf8ArraysD' = decodeUtf8ArraysWithD ErrorOnCodingFailure
727-- |
728--
729-- /Pre-release/
730{-# INLINE decodeUtf8Arrays' #-}
731decodeUtf8Arrays' :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
732decodeUtf8Arrays' = D.fromStreamD . decodeUtf8ArraysD' . D.toStreamD
734{-# INLINE decodeUtf8ArraysD_ #-}
735decodeUtf8ArraysD_ ::
736 MonadIO m
737 => Stream m (A.Array Word8)
738 -> Stream m Char
739decodeUtf8ArraysD_ = decodeUtf8ArraysWithD DropOnCodingFailure
741-- |
742--
743-- /Pre-release/
744{-# INLINE decodeUtf8Arrays_ #-}
745decodeUtf8Arrays_ ::
746 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
747decodeUtf8Arrays_ =
748 D.fromStreamD . decodeUtf8ArraysD_ . D.toStreamD
750-------------------------------------------------------------------------------
751-- Encoding Unicode (UTF-8) Characters
752-------------------------------------------------------------------------------
754data WList = WCons !Word8 !WList | WNil
756-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
758{-# INLINE ord2 #-}
759ord2 :: Char -> WList
760ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
761 where
762 n = ord c
763 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
764 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
766{-# INLINE ord3 #-}
767ord3 :: Char -> WList
768ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
769 where
770 n = ord c
771 x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
772 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
773 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
775{-# INLINE ord4 #-}
776ord4 :: Char -> WList
777ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
778 where
779 n = ord c
780 x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
781 x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
782 x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
783 x4 = fromIntegral $ (n .&. 0x3F) + 0x80
785#ifndef __GHCJS__
786{-# ANN type EncodeState Fuse #-}
787#endif
788data EncodeState s = EncodeState s !WList
790#ifndef __GHCJS__
791{-# ANN type InvalidAction Fuse #-}
792#endif
793data InvalidAction =
794 DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid
796replaceInvalid :: s -> Step (EncodeState s) a
797replaceInvalid s =
798 Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil)))
800dropInvalid :: s -> Step (EncodeState s) a
801dropInvalid s = Skip (EncodeState s WNil)
803errorOnInvalid :: s -> Step (EncodeState s) a
804errorOnInvalid _ =
805 error $
806 show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:"
807 ++ "Encountered a surrogate"
809{-# INLINE_NORMAL encodeUtf8DGeneric #-}
810encodeUtf8DGeneric ::
811 Monad m
812 => InvalidAction
813 -> Stream m Char
814 -> Stream m Word8
815encodeUtf8DGeneric act (Stream step state) =
816 Stream step' (EncodeState state WNil)
818 where
820 {-# INLINE_LATE step' #-}
821 step' gst (EncodeState st WNil) = do
822 r <- step (adaptState gst) st
823 return $
824 case r of
825 Yield c s ->
826 case ord c of
827 x | x <= 0x7F ->
828 Yield (fromIntegral x) (EncodeState s WNil)
829 | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
830 | x <= 0xFFFF ->
831 case act of
832 DropInvalid ->
833 if isSurrogate c
834 then dropInvalid s
835 else Skip (EncodeState s (ord3 c))
837 ErrorInvalid ->
838 if isSurrogate c
839 then errorOnInvalid s
840 else Skip (EncodeState s (ord3 c))
842 IgnoreInvalid ->
843 Skip (EncodeState s (ord3 c))
845 ReplaceInvalid ->
846 if isSurrogate c
847 then replaceInvalid s
848 else Skip (EncodeState s (ord3 c))
850 | otherwise -> Skip (EncodeState s (ord4 c))
851 Skip s -> Skip (EncodeState s WNil)
852 Stop -> Stop
853 step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
855-- More yield points improve performance, but I am not sure if they can cause
856-- too much code bloat or some trouble with fusion. So keeping only two yield
857-- points for now, one for the ascii chars (fast path) and one for all other
858-- paths (slow path).
859{-# INLINE_NORMAL encodeUtf8D' #-}
860encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8
861encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid
863-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When
864-- any invalid character (U+D800-U+D8FF) is encountered in the input stream the
865-- function errors out.
866--
867-- @since 0.8.0
868{-# INLINE encodeUtf8' #-}
869encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8
870encodeUtf8' = D.fromStreamD . encodeUtf8D' . D.toStreamD
872-- | See section "3.9 Unicode Encoding Forms" in
873-- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf
874--
875{-# INLINE_NORMAL encodeUtf8D #-}
876encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
877encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid
879-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
880-- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the
881-- Unicode replacement character U+FFFD.
882--
883-- /Since: 0.7.0 ("Streamly.Data.Unicode.Stream")/
884--
885-- /Since: 0.8.0 (Lenient Behaviour)/
886{-# INLINE encodeUtf8 #-}
887encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
888encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD
890{-# INLINE_NORMAL encodeUtf8D_ #-}
891encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8
892encodeUtf8D_ = encodeUtf8DGeneric DropInvalid
894-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any
895-- Invalid characters (U+D800-U+D8FF) in the input stream are dropped.
896--
897-- @since 0.8.0
898{-# INLINE encodeUtf8_ #-}
899encodeUtf8_ :: (Monad m, IsStream t) => t m Char -> t m Word8
900encodeUtf8_ = D.fromStreamD . encodeUtf8D_ . D.toStreamD
902-- | Same as 'encodeUtf8'
903--
904{-# DEPRECATED encodeUtf8Lax "Please use 'encodeUtf8' instead" #-}
905{-# INLINE encodeUtf8Lax #-}
906encodeUtf8Lax :: (IsStream t, Monad m) => t m Char -> t m Word8
907encodeUtf8Lax = encodeUtf8
909-------------------------------------------------------------------------------
910-- Encode streams of containers
911-------------------------------------------------------------------------------
913-- | Encode a container to @Array Word8@ provided an unfold to covert it to a
914-- Char stream and an encoding function.
915--
916-- /Internal/
917{-# INLINE encodeObject #-}
918encodeObject :: MonadIO m =>
919 (SerialT m Char -> SerialT m Word8)
920 -> Unfold m a Char
921 -> a
922 -> m (Array Word8)
923encodeObject encode u = S.fold Array.write . encode . S.unfold u
925-- | Encode a stream of container objects using the supplied encoding scheme.
926-- Each object is encoded as an @Array Word8@.
927--
928-- /Internal/
929{-# INLINE encodeObjects #-}
930encodeObjects :: (MonadIO m, IsStream t) =>
931 (SerialT m Char -> SerialT m Word8)
932 -> Unfold m a Char
933 -> t m a
934 -> t m (Array Word8)
935encodeObjects encode u = Serial.mapM (encodeObject encode u)
937-- | Encode a stream of 'String' using the supplied encoding scheme. Each
938-- string is encoded as an @Array Word8@.
939--
940-- @since 0.8.0
941{-# INLINE encodeStrings #-}
942encodeStrings :: (MonadIO m, IsStream t) =>
943 (SerialT m Char -> SerialT m Word8) -> t m String -> t m (Array Word8)
944encodeStrings encode = encodeObjects encode Unfold.fromList
946{-
947-------------------------------------------------------------------------------
948-- Utility operations on strings
949-------------------------------------------------------------------------------
951strip :: IsStream t => t m Char -> t m Char
952strip = undefined
954stripTail :: IsStream t => t m Char -> t m Char
955stripTail = undefined
956-}
958-- | Remove leading whitespace from a string.
959--
960-- > stripHead = S.dropWhile isSpace
961--
962-- /Pre-release/
963{-# INLINE stripHead #-}
964stripHead :: (Monad m, IsStream t) => t m Char -> t m Char
965stripHead = S.dropWhile isSpace
967-- | Fold each line of the stream using the supplied 'Fold'
968-- and stream the result.
969--
970-- >>> Stream.toList $ lines Fold.toList (Stream.fromList "lines\nthis\nstring\n\n\n")
971-- ["lines","this","string","",""]
972--
973-- > lines = S.splitOnSuffix (== '\n')
974--
975-- /Pre-release/
976{-# INLINE lines #-}
977lines :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
978lines = S.splitOnSuffix (== '\n')
980foreign import ccall unsafe "u_iswspace"
981 iswspace :: Int -> Int
983-- | Code copied from base/Data.Char to INLINE it
984{-# INLINE isSpace #-}
985isSpace :: Char -> Bool
986isSpace c
987 | uc <= 0x377 = uc == 32 || uc - 0x9 <= 4 || uc == 0xa0
988 | otherwise = iswspace (ord c) /= 0
989 where
990 uc = fromIntegral (ord c) :: Word
992-- | Fold each word of the stream using the supplied 'Fold'
993-- and stream the result.
994--
995-- >>> Stream.toList $ words Fold.toList (Stream.fromList "fold these words")
996-- ["fold","these","words"]
997--
998-- > words = S.wordsBy isSpace
999--
1000-- /Pre-release/
1001{-# INLINE words #-}
1002words :: (Monad m, IsStream t) => Fold m Char b -> t m Char -> t m b
1003words = S.wordsBy isSpace
1005-- | Unfold a stream to character streams using the supplied 'Unfold'
1006-- and concat the results suffixing a newline character @\\n@ to each stream.
1008-- @
1009-- unlines = Stream.interposeSuffix '\n'
1010-- unlines = Stream.intercalateSuffix Unfold.fromList "\n"
1011-- @
1013-- /Pre-release/
1014{-# INLINE unlines #-}
1015unlines :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1016unlines = S.interposeSuffix '\n'
1018-- | Unfold the elements of a stream to character streams using the supplied
1019-- 'Unfold' and concat the results with a whitespace character infixed between
1020-- the streams.
1022-- @
1023-- unwords = Stream.interpose ' '
1024-- unwords = Stream.intercalate Unfold.fromList " "
1025-- @
1027-- /Pre-release/
1028{-# INLINE unwords #-}
1029unwords :: (MonadIO m, IsStream t) => Unfold m a Char -> t m a -> t m Char
1030unwords = S.interpose ' '