@@ -265,6 +265,7 @@ module Streamly.Streams.StreamD
265 , decodeUtf8
265 , decodeUtf8
266 , encodeUtf8
266 , encodeUtf8
267 , decodeUtf8Lenient
267 , decodeUtf8Lenient
@@ -308,6 +309,11 @@ import qualified Streamly.Memory.Array.Types as A
308import qualified Streamly.Memory.Ring as RB
309import qualified Streamly.Memory.Ring as RB
309import qualified Streamly.Streams.StreamK as K
310import qualified Streamly.Streams.StreamK as K
312+import Foreign.Ptr (plusPtr)
313+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
314+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr)
315+import Data.Array.Unboxed (UArray, listArray, (!))
311------------------------------------------------------------------------------
317------------------------------------------------------------------------------
312-- Construction
318-- Construction
313------------------------------------------------------------------------------
319------------------------------------------------------------------------------
@@ -2966,6 +2972,7 @@ the (Stream step state) = go state
2967-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2973-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2969ord2 :: Char -> [Word8]
2976ord2 :: Char -> [Word8]
2970ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
2977ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
@@ -2973,6 +2980,7 @@ ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
2973 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2980 x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2974 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2981 x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2976ord3 :: Char -> [Word8]
2984ord3 :: Char -> [Word8]
2977ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
2985ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
@@ -2981,6 +2989,7 @@ ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
2981 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2989 x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2982 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2990 x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2984ord4 :: Char -> [Word8]
2993ord4 :: Char -> [Word8]
2985ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
2994ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
@@ -3071,16 +3080,16 @@ validate4 x1 x2 x3 x4 = validate4_1 ||
3071 between x3 0x80 0xBF &&
3080 between x3 0x80 0xBF &&
3072 between x4 0x80 0xBF
3081 between x4 0x80 0xBF
3074−data CodePoint = FreshPoint
3084+ = FreshPoint s
3075− | Two !Word8
3085+ | Two !Word8 s
3076− | GoThree !Word8
3086+ | GoThree !Word8 s
3077− | Three !Word8 !Word8
3087+ | Three !Word8 !Word8 s
3078− | GoFour !Word8
3088+ | GoFour !Word8 s
3079− | Four1 !Word8 !Word8
3089+ | Four1 !Word8 !Word8 s
3080− | Four !Word8 !Word8 !Word8
3090+ | Four !Word8 !Word8 !Word8 s
3081− | YieldAndContinue !Char
3091+ | YieldAndContinue !Char (CPoint s)
3082− | YieldAndStop !Char
3085data CodingFailureMode
3094data CodingFailureMode
3086 = TransliterateCodingFailure
3095 = TransliterateCodingFailure
@@ -3089,51 +3098,51 @@ data CodingFailureMode
3090{-# INLINE_NORMAL decodeUtf8With #-}
3099{-# INLINE_NORMAL decodeUtf8With #-}
3091decodeUtf8With :: Monad m => CodingFailureMode -> Stream m Word8 -> Stream m Char
3100decodeUtf8With :: 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)
3094 {-# INLINE transliterateOrError #-}
3103 {-# INLINE transliterateOrError #-}
3095− {-# INLINE inputUnderflow #-}
3096 transliterateOrError e s =
3104 transliterateOrError e s =
3097 case cfm of
3105 case cfm of
3098 ErrorOnCodingFailure -> error e
3106 ErrorOnCodingFailure -> error e
3099− TransliterateCodingFailure -> Skip (s, YieldAndContinue '\xFFFD')
3107+ TransliterateCodingFailure -> Skip $ YieldAndContinue '\xFFFD' (FreshPoint s)
3100− inputUnderflow s = case cfm of
3108+ {-# INLINE inputUnderflow #-}
3109+ inputUnderflow = case cfm of
3101 ErrorOnCodingFailure -> error "Input Underflow"
3110 ErrorOnCodingFailure -> error "Input Underflow"
3102− TransliterateCodingFailure -> Skip (s, YieldAndStop '\xFFFD')
3111+ TransliterateCodingFailure -> Skip $ YieldAndContinue '\xFFFD' Done
3104 {-# INLINE_LATE step' #-}
3113 {-# INLINE_LATE step' #-}
3105− step' gst (st, FreshPoint) = do
3114+ step' gst (FreshPoint st) = do
3106 r <- step (adaptState gst) st
3115 r <- step (adaptState gst) st
3107 return $
3116 return $
3108 case r of
3117 case r of
3109 Yield c0 s
3118 Yield c0 s
3110 | c0 <= 0x7f ->
3119 | c0 <= 0x7f ->
3111− Skip (s, YieldAndContinue $ unsafeChr (fromIntegral c0))
3120+ Skip $ YieldAndContinue (unsafeChr (fromIntegral c0)) (FreshPoint s)
3112 | c0 >= 0xc0 && c0 <= 0xc1 ->
3121 | c0 >= 0xc0 && c0 <= 0xc1 ->
3113 transliterateOrError "Invalid Overlong forms" s
3122 transliterateOrError "Invalid Overlong forms" s
3114− | c0 >= 0xc2 && c0 <= 0xdf -> Skip (s, Two c0)
3123+ | c0 >= 0xc2 && c0 <= 0xdf -> Skip (Two c0 s)
3115− | c0 >= 0xe0 && c0 <= 0xef -> Skip (s, GoThree c0)
3124+ | c0 >= 0xe0 && c0 <= 0xef -> Skip (GoThree c0 s)
3116− | c0 >= 0xf0 -> Skip (s, GoFour c0)
3125+ | c0 >= 0xf0 -> Skip (GoFour c0 s)
3117 | otherwise -> transliterateOrError "Invalid Sequence" s
3126 | otherwise -> transliterateOrError "Invalid Sequence" s
3118− Skip s -> Skip (s, FreshPoint)
3127+ Skip s -> Skip (FreshPoint s)
3119 Stop -> Stop
3128 Stop -> Stop
3121 -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
3130 -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
3122 -- known.
3131 -- known.
3123− step' gst (st, Two c0) = do
3132+ step' gst (Two c0 st) = do
3124 r <- step (adaptState gst) st
3133 r <- step (adaptState gst) st
3125 return $
3134 return $
3126 case r of
3135 case r of
3127 Yield c1 s
3136 Yield c1 s
3128 | c1 < 0x80 || c1 >= 0xc0 ->
3137 | c1 < 0x80 || c1 >= 0xc0 ->
3129 transliterateOrError "Invalid Sequence" s
3138 transliterateOrError "Invalid Sequence" s
3130− | otherwise -> Skip (s, YieldAndContinue $ chr2 c0 c1)
3139+ | otherwise -> Skip $ YieldAndContinue (chr2 c0 c1) (FreshPoint s)
3131− Skip s -> Skip (s, Two c0)
3140+ Skip s -> Skip $ Two c0 s
3132− Stop -> inputUnderflow st
3141+ Stop -> inputUnderflow
3134 -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
3143 -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
3135 -- known.
3144 -- known.
3136− step' gst (st, GoThree c0) = do
3145+ step' gst (GoThree c0 st) = do
3137 r <- step (adaptState gst) st
3146 r <- step (adaptState gst) st
3138 return $
3147 return $
3139 case r of
3148 case r of
@@ -3141,93 +3150,197 @@ decodeUtf8With cfm (Stream step state) = Stream step' (state, FreshPoint)
3141 | not (validate3 c0 c1 0x80) ->
3150 | not (validate3 c0 c1 0x80) ->
3142 transliterateOrError "Invalid Sequence" s
3151 transliterateOrError "Invalid Sequence" s
3143 -- See #3341@ghc
3152 -- See #3341@ghc
3144− | otherwise -> Skip (s, Three c0 c1)
3153+ | otherwise -> Skip $ Three c0 c1 s
3145− Skip s -> Skip (s, GoThree c0)
3154+ Skip s -> Skip $ GoThree c0 s
3146− Stop -> inputUnderflow st
3155+ Stop -> inputUnderflow
3148 -- Two bytes known of a 3 byte UTF8 encoded unicode character.
3157 -- 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
3150 r <- step (adaptState gst) st
3159 r <- step (adaptState gst) st
3151 return $
3160 return $
3152 case r of
3161 case r of
3153 Yield c2 s
3162 Yield c2 s
3154 | not (validate3 c0 c1 c2) ->
3163 | not (validate3 c0 c1 c2) ->
3155 transliterateOrError "Invalid Sequence" s
3164 transliterateOrError "Invalid Sequence" s
3156− | otherwise -> Skip (s, YieldAndContinue $ chr3 c0 c1 c2)
3165+ | otherwise -> Skip $ YieldAndContinue (chr3 c0 c1 c2) (FreshPoint s)
3157− Skip s -> Skip (s, Three c0 c1)
3166+ Skip s -> Skip $ Three c0 c1 s
3158− Stop -> inputUnderflow st
3167+ Stop -> inputUnderflow
3160 -- One byte known of a four byte UTF8 unicode character.
3169 -- One byte known of a four byte UTF8 unicode character.
3161− step' gst (st, GoFour c0) = do
3170+ step' gst (GoFour c0 st) = do
3162 r <- step (adaptState gst) st
3171 r <- step (adaptState gst) st
3163 return $
3172 return $
3164 case r of
3173 case r of
3165 Yield c1 s
3174 Yield c1 s
3166 | not (validate4 c0 c1 0x80 0x80) ->
3175 | not (validate4 c0 c1 0x80 0x80) ->
3167 transliterateOrError "Invalid Sequence" s
3176 transliterateOrError "Invalid Sequence" s
3168− | otherwise -> Skip (s, Four1 c0 c1)
3177+ | otherwise -> Skip $ Four1 c0 c1 s
3169− Skip s -> Skip (s, GoFour c0)
3178+ Skip s -> Skip $ GoFour c0 s
3170− Stop -> inputUnderflow st
3179+ Stop -> inputUnderflow
3172 -- Two bytes known of a four byte UTF8 unicode character.
3181 -- 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
3174 r <- step (adaptState gst) st
3183 r <- step (adaptState gst) st
3175 return $
3184 return $
3176 case r of
3185 case r of
3177 Yield c2 s
3186 Yield c2 s
3178 | not (validate4 c0 c1 c2 0x80) ->
3187 | not (validate4 c0 c1 c2 0x80) ->
3179 transliterateOrError "Invalid Sequence" s
3188 transliterateOrError "Invalid Sequence" s
3180− | otherwise -> Skip (s, Four c0 c1 c2)
3189+ | otherwise -> Skip $ Four c0 c1 c2 s
3181− Skip s -> Skip (s, Four1 c0 c1)
3190+ Skip s -> Skip $ Four1 c0 c1 s
3182− Stop -> inputUnderflow st
3191+ Stop -> inputUnderflow
3184 -- Three bytes known of a three byte UTF8 unicode character.
3193 -- 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
3186 r <- step (adaptState gst) st
3195 r <- step (adaptState gst) st
3187 return $
3196 return $
3188 case r of
3197 case r of
3189 Yield c3 s
3198 Yield c3 s
3190 | not (validate4 c0 c1 c2 c3) ->
3199 | not (validate4 c0 c1 c2 c3) ->
3191 transliterateOrError "Invalid Sequence" s
3200 transliterateOrError "Invalid Sequence" s
3192− | otherwise -> Skip (s, YieldAndContinue $ chr4 c0 c1 c2 c3)
3201+ | otherwise -> Skip $ YieldAndContinue (chr4 c0 c1 c2 c3) (FreshPoint s)
3193− Skip s -> Skip (s, Four c0 c1 c2)
3202+ Skip s -> Skip $ Four c0 c1 c2 s
3194− Stop -> inputUnderflow st
3203+ Stop -> inputUnderflow
3196 -- This way so that we only need one Yield.
3205 -- This way so that we only need one Yield.
3197− step' _ (s, YieldAndStop c) = return $ Yield c (s, Done)
3206+ --step' _ (YieldAndStop c) = return $ Yield c Done
3198− step' _ (s, YieldAndContinue c) = return $ Yield c (s, FreshPoint)
3207+ step' _ (YieldAndContinue c s) = return $ Yield c s
3199− step' _ (_, Done) = return Stop
3208+ step' _ Done = return Stop
3201−{-# INLINE decodeUtf8 #-}
3202−decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
3203−decodeUtf8 = decodeUtf8With ErrorOnCodingFailure
3205{-# INLINE decodeUtf8Lenient #-}
3210{-# INLINE decodeUtf8Lenient #-}
3206decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3211decodeUtf8Lenient :: Monad m => Stream m Word8 -> Stream m Char
3207decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3212decodeUtf8Lenient = decodeUtf8With TransliterateCodingFailure
3209−data YieldMany x = None
3212{-# INLINE_NORMAL encodeUtf8 #-}
3214{-# INLINE_NORMAL encodeUtf8 #-}
3213encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
3215encodeUtf8 :: 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, [])
3216 {-# INLINE_LATE step' #-}
3218 {-# INLINE_LATE step' #-}
3217− step' gst (st, None) = do
3219+ step' gst (st, []) = do
3218 r <- step (adaptState gst) st
3220 r <- step (adaptState gst) st
3219 return $
3221 return $
3220 case r of
3222 case r of
3221 Yield c s ->
3223 Yield c s ->
3222 case ord c of
3224 case ord c of
3223− x | x <= 0x7F -> Skip (s, YieldMany [fromIntegral x])
3225+ x | x <= 0x7F -> Skip (s, [fromIntegral x])
3224− | x <= 0x7FF -> Skip (s, YieldMany (ord2 c))
3226+ | x <= 0x7FF -> Skip (s, (ord2 c))
3225 | x <= 0xFFFF ->
3227 | x <= 0xFFFF ->
3226 if isSurrogate c
3228 if isSurrogate c
3227 then error "Encountered a surrogate"
3229 then error "Encountered a surrogate"
3228− else Skip (s, YieldMany (ord3 c))
3230+ else Skip (s, (ord3 c))
3229− | otherwise -> Skip (s, YieldMany (ord4 c))
3231+ | otherwise -> Skip (s, (ord4 c))
3230− Skip s -> Skip (s, None)
3232+ Skip s -> Skip (s, [])
3234+ step' _ (s, (x:xs)) = return $ Yield x (s, xs)
3236+type CodePoint = Word32
3237+type DecoderState = Word32
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,
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
3261+{-# INLINE decode #-}
3262+decode :: (DecoderState, CodePoint) -> Word32 -> (DecoderState, CodePoint)
3263+decode (state, codep) byte =
3264+ let t = utf8d ! byte
3267+ then (byte .&. 0x3f) .|. (codep `shiftL` 6)
3268+ else (0xff `shiftR` (fromIntegral t)) .&. byte
3269+ state' = utf8d ! (256 + state + t)
3270+ in (state', codep')
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)
3278+ {-# INLINE_LATE step' #-}
3279+ step' gst (codepointPtr, statePtr, st) = do
3280+ r <- step (adaptState gst) st
3283+ let (sv, cp) = decode (statePtr, codepointPtr) (fromIntegral x)
3286+ 12 -> error "UTF8: REJECT"
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.
3293+data FlattenState s a
3294+ = OuterLoop !CodePoint !DecoderState s
3295+ | InnerLoop !CodePoint !DecoderState s (ForeignPtr a) (Ptr a) (Ptr a)
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.
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)
3306+ {-# INLINE_LATE step' #-}
3307+ step' gst (OuterLoop cp ds st) = do
3308+ r <- step (adaptState gst) st
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)
3231 Stop -> Stop
3315 Stop -> Stop
3232− step' _ (s, YieldMany []) = return $ Skip (s, None)
3316+ step' _ (InnerLoop cp ds st _ p end)
3233− step' _ (s, YieldMany (x:xs)) = return $ Yield x (s, YieldMany xs)
3317+ | p == end = return $ Skip $ OuterLoop cp ds st
3318+ step' _ (InnerLoop codepointPtr statePtr st startf p end) = do
3322+ touchForeignPtr startf
3324+ let (sv, cp) = decode (statePtr, codepointPtr) (fromIntegral x)
3327+ 12 -> error "UTF8: REJECT"
3330+ (unsafeChr (fromIntegral cp))