@@ -1,5 +1,10 @@
11{-# OPTIONS_HADDOCK hide #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE CPP #-}
24{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE PatternSynonyms #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecordWildCards #-}
38
49-- |
510-- Module : Streamly.Data.Internal.Unicode.Stream
@@ -10,15 +15,18 @@
1015-- Stability : experimental
1116-- Portability : GHC
1217--
18+
19+#include "inline.hs"
20+
1321module Streamly.Internal.Data.Unicode.Stream
1422 (
1523 -- * Construction (Decoding)
1624 decodeLatin1
1725 , decodeUtf8
1826 , decodeUtf8Lax
19− , D.DecodeError(..)
20− , D.DecodeState
21− , D.CodePoint
27+ , DecodeError(..)
28+ , DecodeState
29+ , CodePoint
2230 , decodeUtf8Either
2331 , resumeDecodeUtf8Either
2432 , decodeUtf8Arrays
@@ -33,6 +41,16 @@ module Streamly.Internal.Data.Unicode.Stream
3341 , strip -- (dropAround isSpace)
3442 , stripEnd
3543 -}
44+
45+ -- * StreamD UTF8 Encoding / Decoding transformations.
46+ , decodeUtf8D
47+ , encodeUtf8D
48+ , decodeUtf8LenientD
49+ , decodeUtf8EitherD
50+ , resumeDecodeUtf8EitherD
51+ , decodeUtf8ArraysD
52+ , decodeUtf8ArraysLenientD
53+
3654 -- * Transformation
3755 , stripStart
3856 , lines
@@ -42,23 +60,519 @@ module Streamly.Internal.Data.Unicode.Stream
4260 )
4361where
4462
45−import Control.Monad.IO.Class (MonadIO)
63+import Control.Monad.IO.Class (MonadIO, liftIO)
64+import Data.Bits (shiftR, shiftL, (.|.), (.&.))
4665import Data.Char (ord)
4766import Data.Word (Word8)
48−import GHC.Base (unsafeChr)
49−import Streamly (IsStream)
67+import Foreign.ForeignPtr (touchForeignPtr)
68+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
69+import Foreign.Storable (Storable(..))
70+import GHC.Base (assert, unsafeChr)
71+import GHC.ForeignPtr (ForeignPtr (..))
72+import GHC.IO.Encoding.Failure (isSurrogate)
73+import GHC.Ptr (Ptr (..), plusPtr)
5074import Prelude hiding (String, lines, words, unlines, unwords)
75+import System.IO.Unsafe (unsafePerformIO)
76+
77+import Streamly (IsStream)
5178import Streamly.Data.Fold (Fold)
5279import Streamly.Memory.Array (Array)
5380import Streamly.Internal.Data.Unfold (Unfold)
81+import Streamly.Internal.Data.SVar (adaptState)
82+import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..))
83+import Streamly.Internal.Data.Strict (Tuple'(..))
84+
85+#if __GLASGOW_HASKELL__ < 800
86+import Streamly.Internal.Data.Stream.StreamD (pattern Stream)
87+#endif
5488
89+import qualified Streamly.Internal.Memory.Array.Types as A
5590import qualified Streamly.Internal.Prelude as S
5691import qualified Streamly.Internal.Data.Stream.StreamD as D
5792
5893-------------------------------------------------------------------------------
59−-- Encoding/Decoding Unicode Characters
94+-- Encoding/Decoding Unicode (UTF-8) Characters
6095-------------------------------------------------------------------------------
6196
97+-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
98+
99+data WList = WCons !Word8 !WList | WNil
100+
101+{-# INLINE ord2 #-}
102+ord2 :: Char -> WList
103+ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))
104+ where
105+ n = ord c
106+ x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
107+ x2 = fromIntegral $ (n .&. 0x3F) + 0x80
108+
109+{-# INLINE ord3 #-}
110+ord3 :: Char -> WList
111+ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))
112+ where
113+ n = ord c
114+ x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
115+ x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
116+ x3 = fromIntegral $ (n .&. 0x3F) + 0x80
117+
118+{-# INLINE ord4 #-}
119+ord4 :: Char -> WList
120+ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))
121+ where
122+ n = ord c
123+ x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
124+ x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
125+ x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
126+ x4 = fromIntegral $ (n .&. 0x3F) + 0x80
127+
128+data CodingFailureMode
129+ = TransliterateCodingFailure
130+ | ErrorOnCodingFailure
131+ deriving (Show)
132+
133+{-# INLINE replacementChar #-}
134+replacementChar :: Char
135+replacementChar = '\xFFFD'
136+
137+-- Int helps in cheaper conversion from Int to Char
138+type CodePoint = Int
139+type DecodeState = Word8
140+
141+-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.
142+
143+-- XXX Use names decodeSuccess = 0, decodeFailure = 12
144+
145+decodeTable :: [Word8]
146+decodeTable = [
147+ -- The first part of the table maps bytes to character classes that
148+ -- to reduce the size of the transition table and create bitmasks.
149+ 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,
150+ 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,
151+ 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,
152+ 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,
153+ 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,
154+ 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,
155+ 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,
156+ 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,
157+
158+ -- The second part is a transition table that maps a combination
159+ -- of a state of the automaton and a character class to a state.
160+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
161+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
162+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
163+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
164+ 12,36,12,12,12,12,12,12,12,12,12,12
165+ ]
166+
167+utf8d :: A.Array Word8
168+utf8d =
169+ unsafePerformIO
170+ -- Aligning to cacheline makes a barely noticeable difference
171+ -- XXX currently alignment is not implemented for unmanaged allocation
172+ $ D.runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))
173+ (D.fromList decodeTable)
174+
175+-- | Return element at the specified index without checking the bounds.
176+-- and without touching the foreign ptr.
177+{-# INLINE_NORMAL unsafePeekElemOff #-}
178+unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a
179+unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x
180+
181+-- decode is split into two separate cases to avoid branching instructions.
182+-- From the higher level flow we already know which case we are in so we can
183+-- call the appropriate decode function.
184+--
185+-- When the state is 0
186+{-# INLINE decode0 #-}
187+decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint
188+decode0 table byte =
189+ let !t = table `unsafePeekElemOff` fromIntegral byte
190+ !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte
191+ !state' = table `unsafePeekElemOff` (256 + fromIntegral t)
192+ in assert ((byte > 0x7f || error showByte)
193+ && (state' /= 0 || error (showByte ++ showTable)))
194+ (Tuple' state' codep')
195+
196+ where
197+
198+ utf8table =
199+ let !(Ptr addr) = table
200+ end = table `plusPtr` 364
201+ in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
202+ showByte = "Streamly: decode0: byte: " ++ show byte
203+ showTable = " table: " ++ show utf8table
204+
205+-- When the state is not 0
206+{-# INLINE decode1 #-}
207+decode1
208+ :: Ptr Word8
209+ -> DecodeState
210+ -> CodePoint
211+ -> Word8
212+ -> Tuple' DecodeState CodePoint
213+decode1 table state codep byte =
214+ -- Remember codep is Int type!
215+ -- Can it be unsafe to convert the resulting Int to Char?
216+ let !t = table `unsafePeekElemOff` fromIntegral byte
217+ !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)
218+ !state' = table `unsafePeekElemOff`
219+ (256 + fromIntegral state + fromIntegral t)
220+ in assert (codep' <= 0x10FFFF
221+ || error (showByte ++ showState state codep))
222+ (Tuple' state' codep')
223+ where
224+
225+ utf8table =
226+ let !(Ptr addr) = table
227+ end = table `plusPtr` 364
228+ in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8
229+ showByte = "Streamly: decode1: byte: " ++ show byte
230+ showState st cp =
231+ " state: " ++ show st ++
232+ " codepoint: " ++ show cp ++
233+ " table: " ++ show utf8table
234+
235+-- We can divide the errors in three general categories:
236+-- * A non-starter was encountered in a begin state
237+-- * A starter was encountered without completing a codepoint
238+-- * The last codepoint was not complete (input underflow)
239+--
240+data DecodeError = DecodeError !DecodeState !CodePoint deriving Show
241+
242+data FreshPoint s a
243+ = FreshPointDecodeInit s
244+ | FreshPointDecodeInit1 s Word8
245+ | FreshPointDecodeFirst s Word8
246+ | FreshPointDecoding s !DecodeState !CodePoint
247+ | YieldAndContinue a (FreshPoint s a)
248+ | Done
249+
250+-- XXX Add proper error messages
251+-- XXX Implement this in terms of decodeUtf8Either
252+{-# INLINE_NORMAL decodeUtf8WithD #-}
253+decodeUtf8WithD :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
254+decodeUtf8WithD cfm (Stream step state) =
255+ let A.Array p _ _ = utf8d
256+ !ptr = (unsafeForeignPtrToPtr p)
257+ in Stream (step' ptr) (FreshPointDecodeInit state)
258+ where
259+ {-# INLINE transliterateOrError #-}
260+ transliterateOrError e s =
261+ case cfm of
262+ ErrorOnCodingFailure -> error e
263+ TransliterateCodingFailure -> YieldAndContinue replacementChar s
264+ {-# INLINE inputUnderflow #-}
265+ inputUnderflow =
266+ case cfm of
267+ ErrorOnCodingFailure ->
268+ error "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Input Underflow"
269+ TransliterateCodingFailure -> YieldAndContinue replacementChar Done
270+ {-# INLINE_LATE step' #-}
271+ step' _ gst (FreshPointDecodeInit st) = do
272+ r <- step (adaptState gst) st
273+ return $ case r of
274+ Yield x s -> Skip (FreshPointDecodeInit1 s x)
275+ Skip s -> Skip (FreshPointDecodeInit s)
276+ Stop -> Skip Done
277+
278+ step' _ _ (FreshPointDecodeInit1 st x) = do
279+ -- Note: It is important to use a ">" instead of a "<=" test
280+ -- here for GHC to generate code layout for default branch
281+ -- prediction for the common case. This is fragile and might
282+ -- change with the compiler versions, we need a more reliable
283+ -- "likely" primitive to control branch predication.
284+ case x > 0x7f of
285+ False ->
286+ return $ Skip $ YieldAndContinue
287+ (unsafeChr (fromIntegral x))
288+ (FreshPointDecodeInit st)
289+ -- Using a separate state here generates a jump to a
290+ -- separate code block in the core which seems to perform
291+ -- slightly better for the non-ascii case.
292+ True -> return $ Skip $ FreshPointDecodeFirst st x
293+
294+ -- XXX should we merge it with FreshPointDecodeInit1?
295+ step' table _ (FreshPointDecodeFirst st x) = do
296+ let (Tuple' sv cp) = decode0 table x
297+ return $
298+ case sv of
299+ 12 ->
300+ Skip $
301+ transliterateOrError
302+ "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
303+ (FreshPointDecodeInit st)
304+ 0 -> error "unreachable state"
305+ _ -> Skip (FreshPointDecoding st sv cp)
306+
307+ -- We recover by trying the new byte x a starter of a new codepoint.
308+ -- XXX need to use the same recovery in array decoding routine as well
309+ step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
310+ r <- step (adaptState gst) st
311+ case r of
312+ Yield x s -> do
313+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
314+ return $
315+ case sv of
316+ 0 -> Skip $ YieldAndContinue (unsafeChr cp)
317+ (FreshPointDecodeInit s)
318+ 12 ->
319+ Skip $
320+ transliterateOrError
321+ "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"
322+ (FreshPointDecodeInit1 s x)
323+ _ -> Skip (FreshPointDecoding s sv cp)
324+ Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
325+ Stop -> return $ Skip inputUnderflow
326+
327+ step' _ _ (YieldAndContinue c s) = return $ Yield c s
328+ step' _ _ Done = return Stop
329+
330+{-# INLINE decodeUtf8D #-}
331+decodeUtf8D :: Monad m => Stream m Word8 -> Stream m Char
332+decodeUtf8D = decodeUtf8WithD ErrorOnCodingFailure
333+
334+{-# INLINE decodeUtf8LenientD #-}
335+decodeUtf8LenientD :: Monad m => Stream m Word8 -> Stream m Char
336+decodeUtf8LenientD = decodeUtf8WithD TransliterateCodingFailure
337+
338+{-# INLINE_NORMAL resumeDecodeUtf8EitherD #-}
339+resumeDecodeUtf8EitherD
340+ :: Monad m
341+ => DecodeState
342+ -> CodePoint
343+ -> Stream m Word8
344+ -> Stream m (Either DecodeError Char)
345+resumeDecodeUtf8EitherD dst codep (Stream step state) =
346+ let A.Array p _ _ = utf8d
347+ !ptr = (unsafeForeignPtrToPtr p)
348+ stt =
349+ if dst == 0
350+ then FreshPointDecodeInit state
351+ else FreshPointDecoding state dst codep
352+ in Stream (step' ptr) stt
353+ where
354+ {-# INLINE_LATE step' #-}
355+ step' _ gst (FreshPointDecodeInit st) = do
356+ r <- step (adaptState gst) st
357+ return $ case r of
358+ Yield x s -> Skip (FreshPointDecodeInit1 s x)
359+ Skip s -> Skip (FreshPointDecodeInit s)
360+ Stop -> Skip Done
361+
362+ step' _ _ (FreshPointDecodeInit1 st x) = do
363+ -- Note: It is important to use a ">" instead of a "<=" test
364+ -- here for GHC to generate code layout for default branch
365+ -- prediction for the common case. This is fragile and might
366+ -- change with the compiler versions, we need a more reliable
367+ -- "likely" primitive to control branch predication.
368+ case x > 0x7f of
369+ False ->
370+ return $ Skip $ YieldAndContinue
371+ (Right $ unsafeChr (fromIntegral x))
372+ (FreshPointDecodeInit st)
373+ -- Using a separate state here generates a jump to a
374+ -- separate code block in the core which seems to perform
375+ -- slightly better for the non-ascii case.
376+ True -> return $ Skip $ FreshPointDecodeFirst st x
377+
378+ -- XXX should we merge it with FreshPointDecodeInit1?
379+ step' table _ (FreshPointDecodeFirst st x) = do
380+ let (Tuple' sv cp) = decode0 table x
381+ return $
382+ case sv of
383+ 12 ->
384+ Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))
385+ (FreshPointDecodeInit st)
386+ 0 -> error "unreachable state"
387+ _ -> Skip (FreshPointDecoding st sv cp)
388+
389+ -- We recover by trying the new byte x a starter of a new codepoint.
390+ -- XXX need to use the same recovery in array decoding routine as well
391+ step' table gst (FreshPointDecoding st statePtr codepointPtr) = do
392+ r <- step (adaptState gst) st
393+ case r of
394+ Yield x s -> do
395+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
396+ return $
397+ case sv of
398+ 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)
399+ (FreshPointDecodeInit s)
400+ 12 ->
401+ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)
402+ (FreshPointDecodeInit1 s x)
403+ _ -> Skip (FreshPointDecoding s sv cp)
404+ Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)
405+ Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done
406+
407+ step' _ _ (YieldAndContinue c s) = return $ Yield c s
408+ step' _ _ Done = return Stop
409+
410+{-# INLINE_NORMAL decodeUtf8EitherD #-}
411+decodeUtf8EitherD :: Monad m
412+ => Stream m Word8 -> Stream m (Either DecodeError Char)
413+decodeUtf8EitherD = resumeDecodeUtf8EitherD 0 0
414+
415+data FlattenState s a
416+ = OuterLoop s !(Maybe (DecodeState, CodePoint))
417+ | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)
418+ | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8
419+ | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)
420+ !DecodeState !CodePoint
421+ | YAndC !Char (FlattenState s a) -- These constructors can be
422+ -- encoded in the FreshPoint
423+ -- type, I prefer to keep these
424+ -- flat even though that means
425+ -- coming up with new names
426+ | D
427+
428+-- The normal decodeUtf8 above should fuse with flattenArrays
429+-- to create this exact code but it doesn't for some reason, as of now this
430+-- remains the fastest way I could figure out to decodeUtf8.
431+--
432+-- XXX Add Proper error messages
433+{-# INLINE_NORMAL decodeUtf8ArraysWithD #-}
434+decodeUtf8ArraysWithD ::
435+ MonadIO m
436+ => CodingFailureMode
437+ -> Stream m (A.Array Word8)
438+ -> Stream m Char
439+decodeUtf8ArraysWithD cfm (Stream step state) =
440+ let A.Array p _ _ = utf8d
441+ !ptr = (unsafeForeignPtrToPtr p)
442+ in Stream (step' ptr) (OuterLoop state Nothing)
443+ where
444+ {-# INLINE transliterateOrError #-}
445+ transliterateOrError e s =
446+ case cfm of
447+ ErrorOnCodingFailure -> error e
448+ TransliterateCodingFailure -> YAndC replacementChar s
449+ {-# INLINE inputUnderflow #-}
450+ inputUnderflow =
451+ case cfm of
452+ ErrorOnCodingFailure ->
453+ error
454+ "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Input Underflow"
455+ TransliterateCodingFailure -> YAndC replacementChar D
456+ {-# INLINE_LATE step' #-}
457+ step' _ gst (OuterLoop st Nothing) = do
458+ r <- step (adaptState gst) st
459+ return $
460+ case r of
461+ Yield A.Array {..} s ->
462+ let p = unsafeForeignPtrToPtr aStart
463+ in Skip (InnerLoopDecodeInit s aStart p aEnd)
464+ Skip s -> Skip (OuterLoop s Nothing)
465+ Stop -> Skip D
466+ step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do
467+ r <- step (adaptState gst) st
468+ return $
469+ case r of
470+ Yield A.Array {..} s ->
471+ let p = unsafeForeignPtrToPtr aStart
472+ in Skip (InnerLoopDecoding s aStart p aEnd ds cp)
473+ Skip s -> Skip (OuterLoop s dst)
474+ Stop -> Skip inputUnderflow
475+ step' _ _ (InnerLoopDecodeInit st startf p end)
476+ | p == end = do
477+ liftIO $ touchForeignPtr startf
478+ return $ Skip $ OuterLoop st Nothing
479+ step' _ _ (InnerLoopDecodeInit st startf p end) = do
480+ x <- liftIO $ peek p
481+ -- Note: It is important to use a ">" instead of a "<=" test here for
482+ -- GHC to generate code layout for default branch prediction for the
483+ -- common case. This is fragile and might change with the compiler
484+ -- versions, we need a more reliable "likely" primitive to control
485+ -- branch predication.
486+ case x > 0x7f of
487+ False ->
488+ return $ Skip $ YAndC
489+ (unsafeChr (fromIntegral x))
490+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
491+ -- Using a separate state here generates a jump to a separate code
492+ -- block in the core which seems to perform slightly better for the
493+ -- non-ascii case.
494+ True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x
495+
496+ step' table _ (InnerLoopDecodeFirst st startf p end x) = do
497+ let (Tuple' sv cp) = decode0 table x
498+ return $
499+ case sv of
500+ 12 ->
501+ Skip $
502+ transliterateOrError
503+ "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
504+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
505+ 0 -> error "unreachable state"
506+ _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
507+ step' _ _ (InnerLoopDecoding st startf p end sv cp)
508+ | p == end = do
509+ liftIO $ touchForeignPtr startf
510+ return $ Skip $ OuterLoop st (Just (sv, cp))
511+ step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do
512+ x <- liftIO $ peek p
513+ let (Tuple' sv cp) = decode1 table statePtr codepointPtr x
514+ return $
515+ case sv of
516+ 0 ->
517+ Skip $
518+ YAndC
519+ (unsafeChr cp)
520+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
521+ 12 ->
522+ Skip $
523+ transliterateOrError
524+ "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"
525+ (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)
526+ _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)
527+ step' _ _ (YAndC c s) = return $ Yield c s
528+ step' _ _ D = return Stop
529+
530+{-# INLINE decodeUtf8ArraysD #-}
531+decodeUtf8ArraysD ::
532+ MonadIO m
533+ => Stream m (A.Array Word8)
534+ -> Stream m Char
535+decodeUtf8ArraysD = decodeUtf8ArraysWithD ErrorOnCodingFailure
536+
537+{-# INLINE decodeUtf8ArraysLenientD #-}
538+decodeUtf8ArraysLenientD ::
539+ MonadIO m
540+ => Stream m (A.Array Word8)
541+ -> Stream m Char
542+decodeUtf8ArraysLenientD = decodeUtf8ArraysWithD TransliterateCodingFailure
543+
544+data EncodeState s = EncodeState s !WList
545+
546+-- More yield points improve performance, but I am not sure if they can cause
547+-- too much code bloat or some trouble with fusion. So keeping only two yield
548+-- points for now, one for the ascii chars (fast path) and one for all other
549+-- paths (slow path).
550+{-# INLINE_NORMAL encodeUtf8D #-}
551+encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8
552+encodeUtf8D (Stream step state) = Stream step' (EncodeState state WNil)
553+ where
554+ {-# INLINE_LATE step' #-}
555+ step' gst (EncodeState st WNil) = do
556+ r <- step (adaptState gst) st
557+ return $
558+ case r of
559+ Yield c s ->
560+ case ord c of
561+ x
562+ | x <= 0x7F ->
563+ Yield (fromIntegral x) (EncodeState s WNil)
564+ | x <= 0x7FF -> Skip (EncodeState s (ord2 c))
565+ | x <= 0xFFFF ->
566+ if isSurrogate c
567+ then error
568+ "Streamly.Internal.Data.Stream.StreamD.encodeUtf8: Encountered a surrogate"
569+ else Skip (EncodeState s (ord3 c))
570+ | otherwise -> Skip (EncodeState s (ord4 c))
571+ Skip s -> Skip (EncodeState s WNil)
572+ Stop -> Stop
573+ step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)
574+
575+
62576-- | Decode a stream of bytes to Unicode characters by mapping each byte to a
63577-- corresponding Unicode 'Char' in 0-255 range.
64578--
@@ -79,8 +593,8 @@ encodeLatin1 = S.map convert
79593 convert c =
80594 let codepoint = ord c
81595 in if codepoint > 255
82− then error $ "Streamly.String.encodeLatin1 invalid \
83− \input char codepoint " ++ show codepoint
596+ then error $ "Streamly.String.encodeLatin1 invalid " ++
597+ "input char codepoint " ++ show codepoint
84598 else fromIntegral codepoint
85599
86600-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond
@@ -98,14 +612,14 @@ encodeLatin1Lax = S.map (fromIntegral . ord)
98612-- /Since: 0.7.0/
99613{-# INLINE decodeUtf8 #-}
100614decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char
101−decodeUtf8 = D.fromStreamD . D.decodeUtf8 . D.toStreamD
615+decodeUtf8 = D.fromStreamD . decodeUtf8D . D.toStreamD
102616
103617-- |
104618--
105619-- /Internal/
106620{-# INLINE decodeUtf8Arrays #-}
107621decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
108−decodeUtf8Arrays = D.fromStreamD . D.decodeUtf8Arrays . D.toStreamD
622+decodeUtf8Arrays = D.fromStreamD . decodeUtf8ArraysD . D.toStreamD
109623
110624-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.
111625-- Any invalid codepoint encountered is replaced with the unicode replacement
@@ -114,15 +628,15 @@ decodeUtf8Arrays = D.fromStreamD . D.decodeUtf8Arrays . D.toStreamD
114628-- /Since: 0.7.0/
115629{-# INLINE decodeUtf8Lax #-}
116630decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char
117−decodeUtf8Lax = D.fromStreamD . D.decodeUtf8Lenient . D.toStreamD
631+decodeUtf8Lax = D.fromStreamD . decodeUtf8LenientD . D.toStreamD
118632
119633-- |
120634--
121635-- /Internal/
122636{-# INLINE decodeUtf8Either #-}
123637decodeUtf8Either :: (Monad m, IsStream t)
124− => t m Word8 -> t m (Either D.DecodeError Char)
125−decodeUtf8Either = D.fromStreamD . D.decodeUtf8Either . D.toStreamD
638+ => t m Word8 -> t m (Either DecodeError Char)
639+decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD
126640
127641-- |
128642--
@@ -130,12 +644,12 @@ decodeUtf8Either = D.fromStreamD . D.decodeUtf8Either . D.toStreamD
130644{-# INLINE resumeDecodeUtf8Either #-}
131645resumeDecodeUtf8Either
132646 :: (Monad m, IsStream t)
133− => D.DecodeState
134− -> D.CodePoint
647+ => DecodeState
648+ -> CodePoint
135649 -> t m Word8
136− -> t m (Either D.DecodeError Char)
650+ -> t m (Either DecodeError Char)
137651resumeDecodeUtf8Either st cp =
138− D.fromStreamD . D.resumeDecodeUtf8Either st cp . D.toStreamD
652+ D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD
139653
140654-- |
141655--
@@ -144,14 +658,14 @@ resumeDecodeUtf8Either st cp =
144658decodeUtf8ArraysLenient ::
145659 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char
146660decodeUtf8ArraysLenient =
147− D.fromStreamD . D.decodeUtf8ArraysLenient . D.toStreamD
661+ D.fromStreamD . decodeUtf8ArraysLenientD . D.toStreamD
148662
149663-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.
150664--
151665-- /Since: 0.7.0/
152666{-# INLINE encodeUtf8 #-}
153667encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8
154−encodeUtf8 = D.fromStreamD . D.encodeUtf8 . D.toStreamD
668+encodeUtf8 = D.fromStreamD . encodeUtf8D . D.toStreamD
155669
156670{-
157671-------------------------------------------------------------------------------