634df53 · streamly · git.iko.soy

git.iko.soy/streamly

on master help sign in

Move encodeUtf8/decodeUtf8 implementation from StreamD module.

634df53Pranay Sashank7 years ago

src/Streamly/Internal/Data/Stream/StreamD.hs−505

compare with master

unifiedsplit

@@ -292,18 +292,6 @@ module Streamly.Internal.Data.Stream.StreamD

292 , finally

293 , handle

294

295− -- * UTF8 Encoding / Decoding transformations.

296− , DecodeError(..)

297− , DecodeState

298− , CodePoint

299− , decodeUtf8

300− , encodeUtf8

301− , decodeUtf8Lenient

302− , decodeUtf8Either

303− , resumeDecodeUtf8Either

304− , decodeUtf8Arrays

305− , decodeUtf8ArraysLenient

306−

307 -- * Concurrent Application

295 -- * Concurrent Application

308 , mkParallel

296 , mkParallel

309 , applyParallel

297 , applyParallel

@@ -325,13 +313,7 @@ import Data.Maybe (fromJust, isJust, isNothing)

325import Data.Word (Word32)

313import Data.Word (Word32)

326import Foreign.Ptr (Ptr)

314import Foreign.Ptr (Ptr)

327import Foreign.Storable (Storable(..))

315import Foreign.Storable (Storable(..))

328−import GHC.Base (assert, unsafeChr, ord)

329−import GHC.IO.Encoding.Failure (isSurrogate)

330−import GHC.ForeignPtr (ForeignPtr (..))

331−import GHC.Ptr (Ptr (..))

332import GHC.Types (SPEC(..))

316import GHC.Types (SPEC(..))

333−import GHC.Word (Word8(..))

334−import System.IO.Unsafe (unsafePerformIO)

335import System.Mem (performMajorGC)

317import System.Mem (performMajorGC)

336import Prelude

318import Prelude

337 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,

319 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,

@@ -351,7 +333,6 @@ import Streamly.Internal.Data.Fold.Types (Fold(..))

351import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))

333import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))

352import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)

334import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime)

353import Streamly.Internal.Data.Unfold.Types (Unfold(..))

335import Streamly.Internal.Data.Unfold.Types (Unfold(..))

354−import Streamly.Internal.Data.Strict (Tuple'(..))

355

336

356import Streamly.Internal.Data.Stream.StreamD.Type

337import Streamly.Internal.Data.Stream.StreamD.Type

357import Streamly.Internal.Data.SVar

338import Streamly.Internal.Data.SVar

@@ -362,10 +343,6 @@ import qualified Streamly.Internal.Data.Fold as FL

362import qualified Streamly.Memory.Ring as RB

343import qualified Streamly.Memory.Ring as RB

363import qualified Streamly.Internal.Data.Stream.StreamK as K

344import qualified Streamly.Internal.Data.Stream.StreamK as K

364

345

365−import Foreign.Ptr (plusPtr)

366−import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

367−import Foreign.ForeignPtr (touchForeignPtr)

368−

369------------------------------------------------------------------------------

346------------------------------------------------------------------------------

370-- Construction

347-- Construction

371------------------------------------------------------------------------------

348------------------------------------------------------------------------------

@@ -3649,492 +3626,10 @@ the (Stream step state) = go state

3649 Skip s -> go' n s

3626 Skip s -> go' n s

3650 Stop -> return (Just n)

3627 Stop -> return (Just n)

3651

3628

3652−--------------------------------------------------------------------------------

3653−-- UTF8 Encoding / Decoding

3654−--------------------------------------------------------------------------------

3655−

3656−-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.

3657−

3658−{-# INLINE ord2 #-}

3659−ord2 :: Char -> WList

3660−ord2 c = assert (n >= 0x80 && n <= 0x07ff) (WCons x1 (WCons x2 WNil))

3661− where

3662− n = ord c

3663− x1 = fromIntegral $ (n `shiftR` 6) + 0xC0

3664− x2 = fromIntegral $ (n .&. 0x3F) + 0x80

3665−

3666−{-# INLINE ord3 #-}

3667−ord3 :: Char -> WList

3668−ord3 c = assert (n >= 0x0800 && n <= 0xffff) (WCons x1 (WCons x2 (WCons x3 WNil)))

3669− where

3670− n = ord c

3671− x1 = fromIntegral $ (n `shiftR` 12) + 0xE0

3672− x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80

3673− x3 = fromIntegral $ (n .&. 0x3F) + 0x80

3674−

3675−{-# INLINE ord4 #-}

3676−ord4 :: Char -> WList

3677−ord4 c = assert (n >= 0x10000) (WCons x1 (WCons x2 (WCons x3 (WCons x4 WNil))))

3678− where

3679− n = ord c

3680− x1 = fromIntegral $ (n `shiftR` 18) + 0xF0

3681− x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80

3682− x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80

3683− x4 = fromIntegral $ (n .&. 0x3F) + 0x80

3684−

3685−data CodingFailureMode

3686− = TransliterateCodingFailure

3687− | ErrorOnCodingFailure

3688− deriving (Show)

3689−

3690−{-# INLINE replacementChar #-}

3691−replacementChar :: Char

3692−replacementChar = '\xFFFD'

3693−

3694−-- Int helps in cheaper conversion from Int to Char

3695−type CodePoint = Int

3696−type DecodeState = Word8

3697−

3698−-- See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.

3699−

3700{-# INLINE runFold #-}

3629{-# INLINE runFold #-}

3701runFold :: (Monad m) => Fold m a b -> Stream m a -> m b

3630runFold :: (Monad m) => Fold m a b -> Stream m a -> m b

3702runFold (Fold step begin done) = foldlMx' step begin done

3631runFold (Fold step begin done) = foldlMx' step begin done

3703

3632

3704−-- XXX Use names decodeSuccess = 0, decodeFailure = 12

3705−

3706−decodeTable :: [Word8]

3707−decodeTable = [

3708− -- The first part of the table maps bytes to character classes that

3709− -- to reduce the size of the transition table and create bitmasks.

3710− 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,

3711− 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,

3712− 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,

3713− 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,

3714− 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,

3715− 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,

3716− 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,

3717− 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,

3718−

3719− -- The second part is a transition table that maps a combination

3720− -- of a state of the automaton and a character class to a state.

3721− 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,

3722− 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,

3723− 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,

3724− 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,

3725− 12,36,12,12,12,12,12,12,12,12,12,12

3726− ]

3727−

3728−utf8d :: A.Array Word8

3729−utf8d =

3730− unsafePerformIO

3731− -- Aligning to cacheline makes a barely noticeable difference

3732− -- XXX currently alignment is not implemented for unmanaged allocation

3733− $ runFold (A.writeNAlignedUnmanaged 64 (length decodeTable))

3734− (fromList decodeTable)

3735−

3736−-- | Return element at the specified index without checking the bounds.

3737−-- and without touching the foreign ptr.

3738−{-# INLINE_NORMAL unsafePeekElemOff #-}

3739−unsafePeekElemOff :: forall a. Storable a => Ptr a -> Int -> a

3740−unsafePeekElemOff p i = let !x = A.unsafeInlineIO $ peekElemOff p i in x

3741−

3742−-- decode is split into two separate cases to avoid branching instructions.

3743−-- From the higher level flow we already know which case we are in so we can

3744−-- call the appropriate decode function.

3745−--

3746−-- When the state is 0

3747−{-# INLINE decode0 #-}

3748−decode0 :: Ptr Word8 -> Word8 -> Tuple' DecodeState CodePoint

3749−decode0 table byte =

3750− let !t = table `unsafePeekElemOff` fromIntegral byte

3751− !codep' = (0xff `shiftR` (fromIntegral t)) .&. fromIntegral byte

3752− !state' = table `unsafePeekElemOff` (256 + fromIntegral t)

3753− in assert ((byte > 0x7f || error showByte)

3754− && (state' /= 0 || error (showByte ++ showTable)))

3755− (Tuple' state' codep')

3756−

3757− where

3758−

3759− utf8table =

3760− let !(Ptr addr) = table

3761− end = table `plusPtr` 364

3762− in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8

3763− showByte = "Streamly: decode0: byte: " ++ show byte

3764− showTable = " table: " ++ show utf8table

3765−

3766−-- When the state is not 0

3767−{-# INLINE decode1 #-}

3768−decode1

3769− :: Ptr Word8

3770− -> DecodeState

3771− -> CodePoint

3772− -> Word8

3773− -> Tuple' DecodeState CodePoint

3774−decode1 table state codep byte =

3775− -- Remember codep is Int type!

3776− -- Can it be unsafe to convert the resulting Int to Char?

3777− let !t = table `unsafePeekElemOff` fromIntegral byte

3778− !codep' = (fromIntegral byte .&. 0x3f) .|. (codep `shiftL` 6)

3779− !state' = table `unsafePeekElemOff`

3780− (256 + fromIntegral state + fromIntegral t)

3781− in assert (codep' <= 0x10FFFF

3782− || error (showByte ++ showState state codep))

3783− (Tuple' state' codep')

3784− where

3785−

3786− utf8table =

3787− let !(Ptr addr) = table

3788− end = table `plusPtr` 364

3789− in A.Array (ForeignPtr addr undefined) end end :: A.Array Word8

3790− showByte = "Streamly: decode1: byte: " ++ show byte

3791− showState st cp =

3792− " state: " ++ show st ++

3793− " codepoint: " ++ show cp ++

3794− " table: " ++ show utf8table

3795−

3796−-- We can divide the errors in three general categories:

3797−-- * A non-starter was encountered in a begin state

3798−-- * A starter was encountered without completing a codepoint

3799−-- * The last codepoint was not complete (input underflow)

3800−--

3801−data DecodeError = DecodeError !DecodeState !CodePoint deriving Show

3802−

3803−data FreshPoint s a

3804− = FreshPointDecodeInit s

3805− | FreshPointDecodeInit1 s Word8

3806− | FreshPointDecodeFirst s Word8

3807− | FreshPointDecoding s !DecodeState !CodePoint

3808− | YieldAndContinue a (FreshPoint s a)

3809− | Done

3810−

3811−-- XXX Add proper error messages

3812−-- XXX Implement this in terms of decodeUtf8Either

3813−{-# INLINE_NORMAL decodeUtf8With #-}

3814−decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char

3815−decodeUtf8With cfm (Stream step state) =

3816− let Array p _ _ = utf8d

3817− !ptr = (unsafeForeignPtrToPtr p)

3818− in Stream (step' ptr) (FreshPointDecodeInit state)

3819− where

3820− {-# INLINE transliterateOrError #-}

3821− transliterateOrError e s =

3822− case cfm of

3823− ErrorOnCodingFailure -> error e

3824− TransliterateCodingFailure -> YieldAndContinue replacementChar s

3825− {-# INLINE inputUnderflow #-}

3826− inputUnderflow =

3827− case cfm of

3828− ErrorOnCodingFailure ->

3829− error "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Input Underflow"

3830− TransliterateCodingFailure -> YieldAndContinue replacementChar Done

3831− {-# INLINE_LATE step' #-}

3832− step' _ gst (FreshPointDecodeInit st) = do

3833− r <- step (adaptState gst) st

3834− return $ case r of

3835− Yield x s -> Skip (FreshPointDecodeInit1 s x)

3836− Skip s -> Skip (FreshPointDecodeInit s)

3837− Stop -> Skip Done

3838−

3839− step' _ _ (FreshPointDecodeInit1 st x) = do

3840− -- Note: It is important to use a ">" instead of a "<=" test

3841− -- here for GHC to generate code layout for default branch

3842− -- prediction for the common case. This is fragile and might

3843− -- change with the compiler versions, we need a more reliable

3844− -- "likely" primitive to control branch predication.

3845− case x > 0x7f of

3846− False ->

3847− return $ Skip $ YieldAndContinue

3848− (unsafeChr (fromIntegral x))

3849− (FreshPointDecodeInit st)

3850− -- Using a separate state here generates a jump to a

3851− -- separate code block in the core which seems to perform

3852− -- slightly better for the non-ascii case.

3853− True -> return $ Skip $ FreshPointDecodeFirst st x

3854−

3855− -- XXX should we merge it with FreshPointDecodeInit1?

3856− step' table _ (FreshPointDecodeFirst st x) = do

3857− let (Tuple' sv cp) = decode0 table x

3858− return $

3859− case sv of

3860− 12 ->

3861− Skip $

3862− transliterateOrError

3863− "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"

3864− (FreshPointDecodeInit st)

3865− 0 -> error "unreachable state"

3866− _ -> Skip (FreshPointDecoding st sv cp)

3867−

3868− -- We recover by trying the new byte x a starter of a new codepoint.

3869− -- XXX need to use the same recovery in array decoding routine as well

3870− step' table gst (FreshPointDecoding st statePtr codepointPtr) = do

3871− r <- step (adaptState gst) st

3872− case r of

3873− Yield x s -> do

3874− let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

3875− return $

3876− case sv of

3877− 0 -> Skip $ YieldAndContinue (unsafeChr cp)

3878− (FreshPointDecodeInit s)

3879− 12 ->

3880− Skip $

3881− transliterateOrError

3882− "Streamly.Internal.Data.Stream.StreamD.decodeUtf8With: Invalid UTF8 codepoint encountered"

3883− (FreshPointDecodeInit1 s x)

3884− _ -> Skip (FreshPointDecoding s sv cp)

3885− Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)

3886− Stop -> return $ Skip inputUnderflow

3887−

3888− step' _ _ (YieldAndContinue c s) = return $ Yield c s

3889− step' _ _ Done = return Stop

3890−

3891−{-# INLINE decodeUtf8 #-}

3892−decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char

3893−decodeUtf8 = decodeUtf8With ErrorOnCodingFailure

3894−

3895−{-# INLINE decodeUtf8Lenient #-}

3896−decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char

3897−decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure

3898−

3899−{-# INLINE_NORMAL resumeDecodeUtf8Either #-}

3900−resumeDecodeUtf8Either

3901− :: Monad m

3902− => DecodeState

3903− -> CodePoint

3904− -> Stream m Word8

3905− -> Stream m (Either DecodeError Char)

3906−resumeDecodeUtf8Either dst codep (Stream step state) =

3907− let Array p _ _ = utf8d

3908− !ptr = (unsafeForeignPtrToPtr p)

3909− stt =

3910− if dst == 0

3911− then FreshPointDecodeInit state

3912− else FreshPointDecoding state dst codep

3913− in Stream (step' ptr) stt

3914− where

3915− {-# INLINE_LATE step' #-}

3916− step' _ gst (FreshPointDecodeInit st) = do

3917− r <- step (adaptState gst) st

3918− return $ case r of

3919− Yield x s -> Skip (FreshPointDecodeInit1 s x)

3920− Skip s -> Skip (FreshPointDecodeInit s)

3921− Stop -> Skip Done

3922−

3923− step' _ _ (FreshPointDecodeInit1 st x) = do

3924− -- Note: It is important to use a ">" instead of a "<=" test

3925− -- here for GHC to generate code layout for default branch

3926− -- prediction for the common case. This is fragile and might

3927− -- change with the compiler versions, we need a more reliable

3928− -- "likely" primitive to control branch predication.

3929− case x > 0x7f of

3930− False ->

3931− return $ Skip $ YieldAndContinue

3932− (Right $ unsafeChr (fromIntegral x))

3933− (FreshPointDecodeInit st)

3934− -- Using a separate state here generates a jump to a

3935− -- separate code block in the core which seems to perform

3936− -- slightly better for the non-ascii case.

3937− True -> return $ Skip $ FreshPointDecodeFirst st x

3938−

3939− -- XXX should we merge it with FreshPointDecodeInit1?

3940− step' table _ (FreshPointDecodeFirst st x) = do

3941− let (Tuple' sv cp) = decode0 table x

3942− return $

3943− case sv of

3944− 12 ->

3945− Skip $ YieldAndContinue (Left $ DecodeError 0 (fromIntegral x))

3946− (FreshPointDecodeInit st)

3947− 0 -> error "unreachable state"

3948− _ -> Skip (FreshPointDecoding st sv cp)

3949−

3950− -- We recover by trying the new byte x a starter of a new codepoint.

3951− -- XXX need to use the same recovery in array decoding routine as well

3952− step' table gst (FreshPointDecoding st statePtr codepointPtr) = do

3953− r <- step (adaptState gst) st

3954− case r of

3955− Yield x s -> do

3956− let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

3957− return $

3958− case sv of

3959− 0 -> Skip $ YieldAndContinue (Right $ unsafeChr cp)

3960− (FreshPointDecodeInit s)

3961− 12 ->

3962− Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr)

3963− (FreshPointDecodeInit1 s x)

3964− _ -> Skip (FreshPointDecoding s sv cp)

3965− Skip s -> return $ Skip (FreshPointDecoding s statePtr codepointPtr)

3966− Stop -> return $ Skip $ YieldAndContinue (Left $ DecodeError statePtr codepointPtr) Done

3967−

3968− step' _ _ (YieldAndContinue c s) = return $ Yield c s

3969− step' _ _ Done = return Stop

3970−

3971−{-# INLINE_NORMAL decodeUtf8Either #-}

3972−decodeUtf8Either :: Monad m

3973− => Stream m Word8 -> Stream m (Either DecodeError Char)

3974−decodeUtf8Either = resumeDecodeUtf8Either 0 0

3975−

3976−data FlattenState s a

3977− = OuterLoop s !(Maybe (DecodeState, CodePoint))

3978− | InnerLoopDecodeInit s (ForeignPtr a) !(Ptr a) !(Ptr a)

3979− | InnerLoopDecodeFirst s (ForeignPtr a) !(Ptr a) !(Ptr a) Word8

3980− | InnerLoopDecoding s (ForeignPtr a) !(Ptr a) !(Ptr a)

3981− !DecodeState !CodePoint

3982− | YAndC !Char (FlattenState s a) -- These constructors can be

3983− -- encoded in the FreshPoint

3984− -- type, I prefer to keep these

3985− -- flat even though that means

3986− -- coming up with new names

3987− | D

3988−

3989−-- The normal decodeUtf8 above should fuse with flattenArrays

3990−-- to create this exact code but it doesn't for some reason, as of now this

3991−-- remains the fastest way I could figure out to decodeUtf8.

3992−--

3993−-- XXX Add Proper error messages

3994−{-# INLINE_NORMAL decodeUtf8ArraysWith #-}

3995−decodeUtf8ArraysWith ::

3996− MonadIO m

3997− => CodingFailureMode

3998− -> Stream m (A.Array Word8)

3999− -> Stream m Char

4000−decodeUtf8ArraysWith cfm (Stream step state) =

4001− let Array p _ _ = utf8d

4002− !ptr = (unsafeForeignPtrToPtr p)

4003− in Stream (step' ptr) (OuterLoop state Nothing)

4004− where

4005− {-# INLINE transliterateOrError #-}

4006− transliterateOrError e s =

4007− case cfm of

4008− ErrorOnCodingFailure -> error e

4009− TransliterateCodingFailure -> YAndC replacementChar s

4010− {-# INLINE inputUnderflow #-}

4011− inputUnderflow =

4012− case cfm of

4013− ErrorOnCodingFailure ->

4014− error

4015− "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Input Underflow"

4016− TransliterateCodingFailure -> YAndC replacementChar D

4017− {-# INLINE_LATE step' #-}

4018− step' _ gst (OuterLoop st Nothing) = do

4019− r <- step (adaptState gst) st

4020− return $

4021− case r of

4022− Yield A.Array {..} s ->

4023− let p = unsafeForeignPtrToPtr aStart

4024− in Skip (InnerLoopDecodeInit s aStart p aEnd)

4025− Skip s -> Skip (OuterLoop s Nothing)

4026− Stop -> Skip D

4027− step' _ gst (OuterLoop st dst@(Just (ds, cp))) = do

4028− r <- step (adaptState gst) st

4029− return $

4030− case r of

4031− Yield A.Array {..} s ->

4032− let p = unsafeForeignPtrToPtr aStart

4033− in Skip (InnerLoopDecoding s aStart p aEnd ds cp)

4034− Skip s -> Skip (OuterLoop s dst)

4035− Stop -> Skip inputUnderflow

4036− step' _ _ (InnerLoopDecodeInit st startf p end)

4037− | p == end = do

4038− liftIO $ touchForeignPtr startf

4039− return $ Skip $ OuterLoop st Nothing

4040− step' _ _ (InnerLoopDecodeInit st startf p end) = do

4041− x <- liftIO $ peek p

4042− -- Note: It is important to use a ">" instead of a "<=" test here for

4043− -- GHC to generate code layout for default branch prediction for the

4044− -- common case. This is fragile and might change with the compiler

4045− -- versions, we need a more reliable "likely" primitive to control

4046− -- branch predication.

4047− case x > 0x7f of

4048− False ->

4049− return $ Skip $ YAndC

4050− (unsafeChr (fromIntegral x))

4051− (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

4052− -- Using a separate state here generates a jump to a separate code

4053− -- block in the core which seems to perform slightly better for the

4054− -- non-ascii case.

4055− True -> return $ Skip $ InnerLoopDecodeFirst st startf p end x

4056−

4057− step' table _ (InnerLoopDecodeFirst st startf p end x) = do

4058− let (Tuple' sv cp) = decode0 table x

4059− return $

4060− case sv of

4061− 12 ->

4062− Skip $

4063− transliterateOrError

4064− "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

4065− (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

4066− 0 -> error "unreachable state"

4067− _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

4068− step' _ _ (InnerLoopDecoding st startf p end sv cp)

4069− | p == end = do

4070− liftIO $ touchForeignPtr startf

4071− return $ Skip $ OuterLoop st (Just (sv, cp))

4072− step' table _ (InnerLoopDecoding st startf p end statePtr codepointPtr) = do

4073− x <- liftIO $ peek p

4074− let (Tuple' sv cp) = decode1 table statePtr codepointPtr x

4075− return $

4076− case sv of

4077− 0 ->

4078− Skip $

4079− YAndC

4080− (unsafeChr cp)

4081− (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

4082− 12 ->

4083− Skip $

4084− transliterateOrError

4085− "Streamly.Internal.Data.Stream.StreamD.decodeUtf8ArraysWith: Invalid UTF8 codepoint encountered"

4086− (InnerLoopDecodeInit st startf (p `plusPtr` 1) end)

4087− _ -> Skip (InnerLoopDecoding st startf (p `plusPtr` 1) end sv cp)

4088− step' _ _ (YAndC c s) = return $ Yield c s

4089− step' _ _ D = return Stop

4090−

4091−{-# INLINE decodeUtf8Arrays #-}

4092−decodeUtf8Arrays ::

4093− MonadIO m

4094− => Stream m (A.Array Word8)

4095− -> Stream m Char

4096−decodeUtf8Arrays = decodeUtf8ArraysWith ErrorOnCodingFailure

4097−

4098−{-# INLINE decodeUtf8ArraysLenient #-}

4099−decodeUtf8ArraysLenient ::

4100− MonadIO m

4101− => Stream m (A.Array Word8)

4102− -> Stream m Char

4103−decodeUtf8ArraysLenient = decodeUtf8ArraysWith TransliterateCodingFailure

4104−

4105−data WList = WCons !Word8 !WList | WNil

4106−

4107−data EncodeState s = EncodeState s !WList

4108−

4109−-- More yield points improve performance, but I am not sure if they can cause

4110−-- too much code bloat or some trouble with fusion. So keeping only two yield

4111−-- points for now, one for the ascii chars (fast path) and one for all other

4112−-- paths (slow path).

4113−{-# INLINE_NORMAL encodeUtf8 #-}

4114−encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8

4115−encodeUtf8 (Stream step state) = Stream step' (EncodeState state WNil)

4116− where

4117− {-# INLINE_LATE step' #-}

4118− step' gst (EncodeState st WNil) = do

4119− r <- step (adaptState gst) st

4120− return $

4121− case r of

4122− Yield c s ->

4123− case ord c of

4124− x

4125− | x <= 0x7F ->

4126− Yield (fromIntegral x) (EncodeState s WNil)

4127− | x <= 0x7FF -> Skip (EncodeState s (ord2 c))

4128− | x <= 0xFFFF ->

4129− if isSurrogate c

4130− then error

4131− "Streamly.Internal.Data.Stream.StreamD.encodeUtf8: Encountered a surrogate"

4132− else Skip (EncodeState s (ord3 c))

4133− | otherwise -> Skip (EncodeState s (ord4 c))

4134− Skip s -> Skip (EncodeState s WNil)

4135− Stop -> Stop

4136− step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs)

4137−

4138-------------------------------------------------------------------------------

3633-------------------------------------------------------------------------------

4139-- Concurrent application and fold

3634-- Concurrent application and fold

4140-------------------------------------------------------------------------------

3635-------------------------------------------------------------------------------

src/Streamly/Internal/Data/Unicode/Stream.hs+534−20

@@ -1,5 +1,10 @@

1{-# OPTIONS_HADDOCK hide #-}

2+{-# LANGUAGE BangPatterns #-}

3+{-# LANGUAGE CPP #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE PatternSynonyms #-}

6+{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE RecordWildCards #-}

4-- |

9-- |

5-- Module : Streamly.Data.Internal.Unicode.Stream

10-- Module : Streamly.Data.Internal.Unicode.Stream

@@ -10,15 +15,18 @@

10-- Stability : experimental

15-- Stability : experimental

11-- Portability : GHC

16-- Portability : GHC

12--

17--

18+

19+#include "inline.hs"

20+

13module Streamly.Internal.Data.Unicode.Stream

21module Streamly.Internal.Data.Unicode.Stream

14 (

22 (

15 -- * Construction (Decoding)

23 -- * Construction (Decoding)

16 decodeLatin1

24 decodeLatin1

17 , decodeUtf8

25 , decodeUtf8

18 , decodeUtf8Lax

26 , decodeUtf8Lax

19− , D.DecodeError(..)

27+ , DecodeError(..)

20− , D.DecodeState

28+ , DecodeState

21− , D.CodePoint

29+ , CodePoint

22 , decodeUtf8Either

30 , decodeUtf8Either

23 , resumeDecodeUtf8Either

31 , resumeDecodeUtf8Either

24 , decodeUtf8Arrays

32 , decodeUtf8Arrays

@@ -33,6 +41,16 @@ module Streamly.Internal.Data.Unicode.Stream

33 , strip -- (dropAround isSpace)

41 , strip -- (dropAround isSpace)

34 , stripEnd

42 , stripEnd

35 -}

43 -}

44+

45+ -- * StreamD UTF8 Encoding / Decoding transformations.

46+ , decodeUtf8D

47+ , encodeUtf8D

48+ , decodeUtf8LenientD

49+ , decodeUtf8EitherD

50+ , resumeDecodeUtf8EitherD

51+ , decodeUtf8ArraysD

52+ , decodeUtf8ArraysLenientD

53+

36 -- * Transformation

54 -- * Transformation

37 , stripStart

55 , stripStart

38 , lines

56 , lines

@@ -42,23 +60,519 @@ module Streamly.Internal.Data.Unicode.Stream

42 )

60 )

43where

61where

45−import Control.Monad.IO.Class (MonadIO)

63+import Control.Monad.IO.Class (MonadIO, liftIO)

64+import Data.Bits (shiftR, shiftL, (.|.), (.&.))

46import Data.Char (ord)

65import Data.Char (ord)

47import Data.Word (Word8)

66import Data.Word (Word8)

67+import Foreign.ForeignPtr (touchForeignPtr)

68+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)

69+import Foreign.Storable (Storable(..))

48−import GHC.Base (unsafeChr)

70+import GHC.Base (assert, unsafeChr)

49−import Streamly (IsStream)

71+import GHC.ForeignPtr (ForeignPtr (..))

72+import GHC.IO.Encoding.Failure (isSurrogate)

73+import GHC.Ptr (Ptr (..), plusPtr)

50import Prelude hiding (String, lines, words, unlines, unwords)

74import Prelude hiding (String, lines, words, unlines, unwords)

75+import System.IO.Unsafe (unsafePerformIO)

76+

77+import Streamly (IsStream)

51import Streamly.Data.Fold (Fold)

78import Streamly.Data.Fold (Fold)

52import Streamly.Memory.Array (Array)

79import Streamly.Memory.Array (Array)

53import Streamly.Internal.Data.Unfold (Unfold)

80import 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

89+import qualified Streamly.Internal.Memory.Array.Types as A

55import qualified Streamly.Internal.Prelude as S

90import qualified Streamly.Internal.Prelude as S

56import qualified Streamly.Internal.Data.Stream.StreamD as D

91import qualified Streamly.Internal.Data.Stream.StreamD as D

58-------------------------------------------------------------------------------

93-------------------------------------------------------------------------------

59−-- Encoding/Decoding Unicode Characters

94+-- Encoding/Decoding Unicode (UTF-8) Characters

60-------------------------------------------------------------------------------

95-------------------------------------------------------------------------------

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+

62-- | Decode a stream of bytes to Unicode characters by mapping each byte to a

576-- | Decode a stream of bytes to Unicode characters by mapping each byte to a

63-- corresponding Unicode 'Char' in 0-255 range.

577-- corresponding Unicode 'Char' in 0-255 range.

64--

578--

@@ -79,8 +593,8 @@ encodeLatin1 = S.map convert

79 convert c =

593 convert c =

80 let codepoint = ord c

594 let codepoint = ord c

81 in if codepoint > 255

595 in if codepoint > 255

82− then error $ "Streamly.String.encodeLatin1 invalid \

596+ then error $ "Streamly.String.encodeLatin1 invalid " ++

83− \input char codepoint " ++ show codepoint

597+ "input char codepoint " ++ show codepoint

84 else fromIntegral codepoint

598 else fromIntegral codepoint

599

86-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond

600-- | Like 'encodeLatin1' but silently truncates and maps input characters beyond

@@ -98,14 +612,14 @@ encodeLatin1Lax = S.map (fromIntegral . ord)

98-- /Since: 0.7.0/

612-- /Since: 0.7.0/

99{-# INLINE decodeUtf8 #-}

613{-# INLINE decodeUtf8 #-}

100decodeUtf8 :: (Monad m, IsStream t) => t m Word8 -> t m Char

614decodeUtf8 :: (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

102

616

103-- |

617-- |

104--

618--

105-- /Internal/

619-- /Internal/

106{-# INLINE decodeUtf8Arrays #-}

620{-# INLINE decodeUtf8Arrays #-}

107decodeUtf8Arrays :: (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

621decodeUtf8Arrays :: (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

109

623

110-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

624-- | Decode a UTF-8 encoded bytestream to a stream of Unicode characters.

111-- Any invalid codepoint encountered is replaced with the unicode replacement

625-- Any invalid codepoint encountered is replaced with the unicode replacement

@@ -114,15 +628,15 @@ decodeUtf8Arrays = D.fromStreamD . D.decodeUtf8Arrays . D.toStreamD

114-- /Since: 0.7.0/

628-- /Since: 0.7.0/

115{-# INLINE decodeUtf8Lax #-}

629{-# INLINE decodeUtf8Lax #-}

116decodeUtf8Lax :: (Monad m, IsStream t) => t m Word8 -> t m Char

630decodeUtf8Lax :: (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

118

632

119-- |

633-- |

120--

634--

121-- /Internal/

635-- /Internal/

122{-# INLINE decodeUtf8Either #-}

636{-# INLINE decodeUtf8Either #-}

123decodeUtf8Either :: (Monad m, IsStream t)

637decodeUtf8Either :: (Monad m, IsStream t)

124− => t m Word8 -> t m (Either D.DecodeError Char)

638+ => t m Word8 -> t m (Either DecodeError Char)

125−decodeUtf8Either = D.fromStreamD . D.decodeUtf8Either . D.toStreamD

639+decodeUtf8Either = D.fromStreamD . decodeUtf8EitherD . D.toStreamD

126

640

127-- |

641-- |

128--

642--

@@ -130,12 +644,12 @@ decodeUtf8Either = D.fromStreamD . D.decodeUtf8Either . D.toStreamD

130{-# INLINE resumeDecodeUtf8Either #-}

644{-# INLINE resumeDecodeUtf8Either #-}

131resumeDecodeUtf8Either

645resumeDecodeUtf8Either

132 :: (Monad m, IsStream t)

646 :: (Monad m, IsStream t)

133− => D.DecodeState

647+ => DecodeState

134− -> D.CodePoint

648+ -> CodePoint

135 -> t m Word8

649 -> t m Word8

136− -> t m (Either D.DecodeError Char)

650+ -> t m (Either DecodeError Char)

137resumeDecodeUtf8Either st cp =

651resumeDecodeUtf8Either st cp =

138− D.fromStreamD . D.resumeDecodeUtf8Either st cp . D.toStreamD

652+ D.fromStreamD . resumeDecodeUtf8EitherD st cp . D.toStreamD

139

653

140-- |

654-- |

141--

655--

@@ -144,14 +658,14 @@ resumeDecodeUtf8Either st cp =

144decodeUtf8ArraysLenient ::

658decodeUtf8ArraysLenient ::

145 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

659 (MonadIO m, IsStream t) => t m (Array Word8) -> t m Char

146decodeUtf8ArraysLenient =

660decodeUtf8ArraysLenient =

147− D.fromStreamD . D.decodeUtf8ArraysLenient . D.toStreamD

661+ D.fromStreamD . decodeUtf8ArraysLenientD . D.toStreamD

148

662

149-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.

663-- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream.

150--

664--

151-- /Since: 0.7.0/

665-- /Since: 0.7.0/

152{-# INLINE encodeUtf8 #-}

666{-# INLINE encodeUtf8 #-}

153encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8

667encodeUtf8 :: (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

155

669

156{-

670{-

157-------------------------------------------------------------------------------

671-------------------------------------------------------------------------------