@@ -265,6 +265,7 @@ module Streamly.Streams.StreamD
265265 , decodeUtf8
266266 , encodeUtf8
267267 , decodeUtf8Lenient
268+ , decodeUtf8Arrays
268269 )
269270where
270271
@@ -308,6 +309,11 @@ import qualified Streamly.Memory.Array.Types as A
308309import qualified Streamly.Memory.Ring as RB
309310import qualified Streamly.Streams.StreamK as K
310311
312+import Foreign.Ptr (plusPtr)
313+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
314+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
315+import Data.Array.Unboxed (UArray, listArray, (!))
316+
311317------------------------------------------------------------------------------
312318-- Construction
313319------------------------------------------------------------------------------
@@ -2966,6 +2972,7 @@ the (Stream step state) = go state
29662972
29672973-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
29682974
2975+{-# INLINE ord2 #-}
29692976ord2 :: Char -> [Word8]
29702977ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
29712978 where
@@ -2973,6 +2980,7 @@ ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
29732980 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
29742981 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
29752982
2983+{-# INLINE ord3 #-}
29762984ord3 :: Char -> [Word8]
29772985ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
29782986 where
@@ -2981,6 +2989,7 @@ ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
29812989 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
29822990 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
29832991
2992+{-# INLINE ord4 #-}
29842993ord4 :: Char -> [Word8]
29852994ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
29862995 where
@@ -3071,16 +3080,16 @@ validate4 x1 x2 x3 x4 = validate4_1 ||
30713080 between x3 0x80 0xBF &&
30723081 between x4 0x80 0xBF
30733082
3074−data CodePoint = FreshPoint
3075− | Two !Word8
3076− | GoThree !Word8
3077− | Three !Word8 !Word8
3078− | GoFour !Word8
3079− | Four1 !Word8 !Word8
3080− | Four !Word8 !Word8 !Word8
3081− | YieldAndContinue !Char
3082− | YieldAndStop !Char
3083− | Done
3083+data CPoint s
3084+ = FreshPoint s
3085+ | Two !Word8 s
3086+ | GoThree !Word8 s
3087+ | Three !Word8 !Word8 s
3088+ | GoFour !Word8 s
3089+ | Four1 !Word8 !Word8 s
3090+ | Four !Word8 !Word8 !Word8 s
3091+ | YieldAndContinue !Char (CPoint s)
3092+ | Done
30843093
30853094data CodingFailureMode
30863095 = TransliterateCodingFailure
@@ -3089,51 +3098,51 @@ data CodingFailureMode
30893098
30903099{-# INLINE_NORMAL decodeUtf8With #-}
30913100decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3092−decodeUtf8With cfm (Stream step state) = Stream step' (state, FreshPoint)
3101+decodeUtf8With cfm (Stream step state) = Stream step' (FreshPoint state)
30933102 where
30943103 {-# INLINE transliterateOrError #-}
3095− {-# INLINE inputUnderflow #-}
30963104 transliterateOrError e s =
30973105 case cfm of
30983106 ErrorOnCodingFailure -> error e
3099− TransliterateCodingFailure -> Skip (s, YieldAndContinue '\xFFFD')
3100− inputUnderflow s = case cfm of
3107+ TransliterateCodingFailure -> Skip $ YieldAndContinue '\xFFFD' (FreshPoint s)
3108+ {-# INLINE inputUnderflow #-}
3109+ inputUnderflow = case cfm of
31013110 ErrorOnCodingFailure -> error "Input Underflow"
3102− TransliterateCodingFailure -> Skip (s, YieldAndStop '\xFFFD')
3111+ TransliterateCodingFailure -> Skip $ YieldAndContinue '\xFFFD' Done
31033112
31043113 {-# INLINE_LATE step' #-}
3105− step' gst (st, FreshPoint) = do
3114+ step' gst (FreshPoint st) = do
31063115 r <- step (adaptState gst) st
31073116 return $
31083117 case r of
31093118 Yield c0 s
31103119 | c0 <= 0x7f ->
3111− Skip (s, YieldAndContinue $ unsafeChr (fromIntegral c0))
3120+ Skip $ YieldAndContinue (unsafeChr (fromIntegral c0)) (FreshPoint s)
31123121 | c0 >= 0xc0 && c0 <= 0xc1 ->
31133122 transliterateOrError "Invalid Overlong forms" s
3114− | c0 >= 0xc2 && c0 <= 0xdf -> Skip (s, Two c0)
3115− | c0 >= 0xe0 && c0 <= 0xef -> Skip (s, GoThree c0)
3116− | c0 >= 0xf0 -> Skip (s, GoFour c0)
3123+ | c0 >= 0xc2 && c0 <= 0xdf -> Skip (Two c0 s)
3124+ | c0 >= 0xe0 && c0 <= 0xef -> Skip (GoThree c0 s)
3125+ | c0 >= 0xf0 -> Skip (GoFour c0 s)
31173126 | otherwise -> transliterateOrError "Invalid Sequence" s
3118− Skip s -> Skip (s, FreshPoint)
3127+ Skip s -> Skip (FreshPoint s)
31193128 Stop -> Stop
31203129
31213130 -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
31223131 -- known.
3123− step' gst (st, Two c0) = do
3132+ step' gst (Two c0 st) = do
31243133 r <- step (adaptState gst) st
31253134 return $
31263135 case r of
31273136 Yield c1 s
31283137 | c1 < 0x80 || c1 >= 0xc0 ->
31293138 transliterateOrError "Invalid Sequence" s
3130− | otherwise -> Skip (s, YieldAndContinue $ chr2 c0 c1)
3131− Skip s -> Skip (s, Two c0)
3132− Stop -> inputUnderflow st
3139+ | otherwise -> Skip $ YieldAndContinue (chr2 c0 c1) (FreshPoint s)
3140+ Skip s -> Skip $ Two c0 s
3141+ Stop -> inputUnderflow
31333142
31343143 -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
31353144 -- known.
3136− step' gst (st, GoThree c0) = do
3145+ step' gst (GoThree c0 st) = do
31373146 r <- step (adaptState gst) st
31383147 return $
31393148 case r of
@@ -3141,93 +3150,197 @@ decodeUtf8With cfm (Stream step state) = Stream step' (state, FreshPoint)
31413150 | not (validate3 c0 c1 0x80) ->
31423151 transliterateOrError "Invalid Sequence" s
31433152 -- See #3341@ghc
3144− | otherwise -> Skip (s, Three c0 c1)
3145− Skip s -> Skip (s, GoThree c0)
3146− Stop -> inputUnderflow st
3153+ | otherwise -> Skip $ Three c0 c1 s
3154+ Skip s -> Skip $ GoThree c0 s
3155+ Stop -> inputUnderflow
31473156
31483157 -- Two bytes known of a 3 byte UTF8 encoded unicode character.
3149− step' gst (st, Three c0 c1) = do
3158+ step' gst (Three c0 c1 st) = do
31503159 r <- step (adaptState gst) st
31513160 return $
31523161 case r of
31533162 Yield c2 s
31543163 | not (validate3 c0 c1 c2) ->
31553164 transliterateOrError "Invalid Sequence" s
3156− | otherwise -> Skip (s, YieldAndContinue $ chr3 c0 c1 c2)
3157− Skip s -> Skip (s, Three c0 c1)
3158− Stop -> inputUnderflow st
3165+ | otherwise -> Skip $ YieldAndContinue (chr3 c0 c1 c2) (FreshPoint s)
3166+ Skip s -> Skip $ Three c0 c1 s
3167+ Stop -> inputUnderflow
31593168
31603169 -- One byte known of a four byte UTF8 unicode character.
3161− step' gst (st, GoFour c0) = do
3170+ step' gst (GoFour c0 st) = do
31623171 r <- step (adaptState gst) st
31633172 return $
31643173 case r of
31653174 Yield c1 s
31663175 | not (validate4 c0 c1 0x80 0x80) ->
31673176 transliterateOrError "Invalid Sequence" s
3168− | otherwise -> Skip (s, Four1 c0 c1)
3169− Skip s -> Skip (s, GoFour c0)
3170− Stop -> inputUnderflow st
3177+ | otherwise -> Skip $ Four1 c0 c1 s
3178+ Skip s -> Skip $ GoFour c0 s
3179+ Stop -> inputUnderflow
31713180
31723181 -- Two bytes known of a four byte UTF8 unicode character.
3173− step' gst (st, Four1 c0 c1) = do
3182+ step' gst (Four1 c0 c1 st) = do
31743183 r <- step (adaptState gst) st
31753184 return $
31763185 case r of
31773186 Yield c2 s
31783187 | not (validate4 c0 c1 c2 0x80) ->
31793188 transliterateOrError "Invalid Sequence" s
3180− | otherwise -> Skip (s, Four c0 c1 c2)
3181− Skip s -> Skip (s, Four1 c0 c1)
3182− Stop -> inputUnderflow st
3189+ | otherwise -> Skip $ Four c0 c1 c2 s
3190+ Skip s -> Skip $ Four1 c0 c1 s
3191+ Stop -> inputUnderflow
31833192
31843193 -- Three bytes known of a three byte UTF8 unicode character.
3185− step' gst (st, Four c0 c1 c2) = do
3194+ step' gst (Four c0 c1 c2 st) = do
31863195 r <- step (adaptState gst) st
31873196 return $
31883197 case r of
31893198 Yield c3 s
31903199 | not (validate4 c0 c1 c2 c3) ->
31913200 transliterateOrError "Invalid Sequence" s
3192− | otherwise -> Skip (s, YieldAndContinue $ chr4 c0 c1 c2 c3)
3193− Skip s -> Skip (s, Four c0 c1 c2)
3194− Stop -> inputUnderflow st
3201+ | otherwise -> Skip $ YieldAndContinue (chr4 c0 c1 c2 c3) (FreshPoint s)
3202+ Skip s -> Skip $ Four c0 c1 c2 s
3203+ Stop -> inputUnderflow
31953204
31963205 -- This way so that we only need one Yield.
3197− step' _ (s, YieldAndStop c) = return $ Yield c (s, Done)
3198− step' _ (s, YieldAndContinue c) = return $ Yield c (s, FreshPoint)
3199− step' _ (_, Done) = return Stop
3200−
3201−{-# INLINE decodeUtf8 #-}
3202−decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3203−decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3206+ --step' _ (YieldAndStop c) = return $ Yield c Done
3207+ step' _ (YieldAndContinue c s) = return $ Yield c s
3208+ step' _ Done = return Stop
32043209
32053210{-# INLINE decodeUtf8Lenient #-}
32063211decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
32073212decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
32083213
3209−data YieldMany x = None
3210− | YieldMany !x
3211−
32123214{-# INLINE_NORMAL encodeUtf8 #-}
32133215encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3214−encodeUtf8 (Stream step state) = Stream step' (state, None)
3216+encodeUtf8 (Stream step state) = Stream step' (state, [])
32153217 where
32163218 {-# INLINE_LATE step' #-}
3217− step' gst (st, None) = do
3219+ step' gst (st, []) = do
32183220 r <- step (adaptState gst) st
32193221 return $
32203222 case r of
32213223 Yield c s ->
32223224 case ord c of
3223− x | x <= 0x7F -> Skip (s, YieldMany [fromIntegral x])
3224− | x <= 0x7FF -> Skip (s, YieldMany (ord2 c))
3225+ x | x <= 0x7F -> Skip (s, [fromIntegral x])
3226+ | x <= 0x7FF -> Skip (s, (ord2 c))
32253227 | x <= 0xFFFF ->
32263228 if isSurrogate c
32273229 then error "Encountered a surrogate"
3228− else Skip (s, YieldMany (ord3 c))
3229− | otherwise -> Skip (s, YieldMany (ord4 c))
3230− Skip s -> Skip (s, None)
3230+ else Skip (s, (ord3 c))
3231+ | otherwise -> Skip (s, (ord4 c))
3232+ Skip s -> Skip (s, [])
3233+ Stop -> Stop
3234+ step' _ (s, (x:xs)) = return $ Yield x (s, xs)
3235+
3236+type CodePoint = Word32
3237+type DecoderState = Word32
3238+
3239+utf8d :: UArray Word32 Word32
3240+utf8d = listArray (0,363) [
3241+ -- The first part of the table maps bytes to character classes that
3242+ -- to reduce the size of the transition table and create bitmasks.
3243+ 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,
3244+ 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,
3245+ 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,
3246+ 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,
3247+ 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,
3248+ 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,
3249+ 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,
3250+ 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,
3251+
3252+ -- The second part is a transition table that maps a combination
3253+ -- of a state of the automaton and a character class to a state.
3254+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,
3255+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,
3256+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,
3257+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,
3258+ 12,36,12,12,12,12,12,12,12,12,12,12
3259+ ]
3260+
3261+{-# INLINE decode #-}
3262+decode :: (DecoderState, CodePoint) -> Word32 -> (DecoderState, CodePoint)
3263+decode (state, codep) byte =
3264+ let t = utf8d ! byte
3265+ codep' =
3266+ if state /= 0
3267+ then (byte .&. 0x3f) .|. (codep `shiftL` 6)
3268+ else (0xff `shiftR` (fromIntegral t)) .&. byte
3269+ state' = utf8d ! (256 + state + t)
3270+ in (state', codep')
3271+
3272+-- XXX Add proper error messages
3273+{-# INLINE_NORMAL decodeUtf8 #-}
3274+decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3275+decodeUtf8 (Stream step state) = Stream step' (0, 0, state)
3276+ where
3277+
3278+ {-# INLINE_LATE step' #-}
3279+ step' gst (codepointPtr, statePtr, st) = do
3280+ r <- step (adaptState gst) st
3281+ case r of
3282+ Yield x s -> do
3283+ let (sv, cp) = decode (statePtr, codepointPtr) (fromIntegral x)
3284+ return $
3285+ case sv of
3286+ 12 -> error "UTF8: REJECT"
3287+ 0 ->
3288+ Yield (unsafeChr (fromIntegral cp)) (cp, sv, s)
3289+ _ -> Skip (cp, sv, s)
3290+ Skip s -> return $ Skip (codepointPtr, statePtr, s)
3291+ Stop -> return Stop -- XXX check whether statePtr is in Accept state or not.
3292+
3293+data FlattenState s a
3294+ = OuterLoop !CodePoint !DecoderState s
3295+ | InnerLoop !CodePoint !DecoderState s (ForeignPtr a) (Ptr a) (Ptr a)
3296+
3297+-- The normal decodeUtf8 above should fuse with flattenArrays
3298+-- to create this exact code but it doesn't for some reason, as of now this
3299+-- remains the fastest way I could figure out to decodeUtf8.
3300+--
3301+-- XXX Add Proper error messages
3302+{-# INLINE_NORMAL decodeUtf8Arrays #-}
3303+decodeUtf8Arrays :: MonadIO m => Stream m (A.Array Word8) -> Stream m Char
3304+decodeUtf8Arrays (Stream step state) = Stream step' (OuterLoop 0 0 state)
3305+ where
3306+ {-# INLINE_LATE step' #-}
3307+ step' gst (OuterLoop cp ds st) = do
3308+ r <- step (adaptState gst) st
3309+ return $
3310+ case r of
3311+ Yield A.Array {..} s ->
3312+ let p = unsafeForeignPtrToPtr aStart
3313+ in Skip (InnerLoop cp ds s aStart p aEnd)
3314+ Skip s -> Skip (OuterLoop cp ds s)
32313315 Stop -> Stop
3232− step' _ (s, YieldMany []) = return $ Skip (s, None)
3233− step' _ (s, YieldMany (x:xs)) = return $ Yield x (s, YieldMany xs)
3316+ step' _ (InnerLoop cp ds st _ p end)
3317+ | p == end = return $ Skip $ OuterLoop cp ds st
3318+ step' _ (InnerLoop codepointPtr statePtr st startf p end) = do
3319+ x <-
3320+ liftIO $ do
3321+ r <- peek p
3322+ touchForeignPtr startf
3323+ return r
3324+ let (sv, cp) = decode (statePtr, codepointPtr) (fromIntegral x)
3325+ return $
3326+ case sv of
3327+ 12 -> error "UTF8: REJECT"
3328+ 0 ->
3329+ Yield
3330+ (unsafeChr (fromIntegral cp))
3331+ (InnerLoop
3332+ cp
3333+ sv
3334+ st
3335+ startf
3336+ (p `plusPtr` 1)
3337+ end)
3338+ _ ->
3339+ Skip
3340+ (InnerLoop
3341+ cp
3342+ sv
3343+ st
3344+ startf
3345+ (p `plusPtr` 1)
3346+ end)