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