@@ -10,6 +10,7 @@
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE ViewPatterns #-}
1212{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE MagicHash #-}
1314
1415#include "inline.hs"
1516
@@ -202,6 +203,8 @@ module Streamly.Streams.StreamD
202203 , sequence
203204
204205 -- * Inserting
206+ , intersperseM
207+ , intersperse
205208 , insertBy
206209
207210 -- * Deleting
@@ -235,6 +238,10 @@ module Streamly.Streams.StreamD
235238 , onException
236239 , finally
237240 , handle
241+
242+ -- * UTF8 Encoding / Decoding transformations.
243+ , decodeUtf8
244+ , encodeUtf8
238245 )
239246where
240247
@@ -242,12 +249,16 @@ import Control.Exception (Exception)
242249import Control.Monad.Catch (MonadCatch)
243250import Control.Monad.IO.Class (MonadIO(..))
244251import Control.Monad.Trans (MonadTrans(lift))
245−import Data.Word (Word32)
246252import Data.Bits (shiftR, shiftL, (.|.), (.&.))
247253import Data.Maybe (fromJust, isJust)
254+import Data.Word (Word32)
248255import Foreign.Ptr (Ptr)
249256import Foreign.Storable (Storable(..))
257+import GHC.Base (assert, Char(..), unsafeChr, (-#), (+#), uncheckedIShiftL#,
258+ word2Int#, chr#, ord)
259+import GHC.IO.Encoding.Failure (isSurrogate)
250260import GHC.Types (SPEC(..))
261+import GHC.Word (Word8(..))
251262import Prelude
252263 hiding (map, mapM, mapM_, repeat, foldr, last, take, filter,
253264 takeWhile, drop, dropWhile, all, any, maximum, minimum, elem,
@@ -2165,6 +2176,38 @@ sequence (Stream step state) = Stream step' state
21652176-- Inserting
21662177------------------------------------------------------------------------------
21672178
2179+data LoopState x s = FirstYield s
2180+ | InterspersingYield s
2181+ | YieldAndCarry x s
2182+
2183+{-# INLINE_NORMAL intersperseM #-}
2184+intersperseM :: Monad m => m a -> Stream m a -> Stream m a
2185+intersperseM m (Stream step state) = Stream step' (FirstYield state)
2186+ where
2187+ {-# INLINE_LATE step' #-}
2188+ step' gst (FirstYield st) = do
2189+ r <- step gst st
2190+ return $
2191+ case r of
2192+ Yield x s -> Skip (YieldAndCarry x s)
2193+ Skip s -> Skip (FirstYield s)
2194+ Stop -> Stop
2195+
2196+ step' gst (InterspersingYield st) = do
2197+ r <- step gst st
2198+ case r of
2199+ Yield x s -> do
2200+ a <- m
2201+ return $ Yield a (YieldAndCarry x s)
2202+ Skip s -> return $ Skip $ InterspersingYield s
2203+ Stop -> return Stop
2204+
2205+ step' _ (YieldAndCarry x st) = return $ Yield x (InterspersingYield st)
2206+
2207+{-# INLINE intersperse #-}
2208+intersperse :: Monad m => a -> Stream m a -> Stream m a
2209+intersperse a = intersperseM (return a)
2210+
21682211{-# INLINE_NORMAL insertBy #-}
21692212insertBy :: Monad m => (a -> a -> Ordering) -> a -> Stream m a -> Stream m a
21702213insertBy cmp a (Stream step state) = Stream step' (state, False, Nothing)
@@ -2355,3 +2398,241 @@ the (Stream step state) = go state
23552398 | otherwise -> return Nothing
23562399 Skip s -> go' n s
23572400 Stop -> return (Just n)
2401+
2402+--------------------------------------------------------------------------------
2403+-- UTF8 Encoding / Decoding
2404+--------------------------------------------------------------------------------
2405+
2406+-- UTF-8 primitives, Lifted from GHC.IO.Encoding.UTF8.
2407+
2408+ord2 :: Char -> [Word8]
2409+ord2 c = assert (n >= 0x80 && n <= 0x07ff) [x1, x2]
2410+ where
2411+ n = ord c
2412+ x1 = fromIntegral $ (n `shiftR` 6) + 0xC0
2413+ x2 = fromIntegral $ (n .&. 0x3F) + 0x80
2414+
2415+ord3 :: Char -> [Word8]
2416+ord3 c = assert (n >= 0x0800 && n <= 0xffff) [x1, x2, x3]
2417+ where
2418+ n = ord c
2419+ x1 = fromIntegral $ (n `shiftR` 12) + 0xE0
2420+ x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2421+ x3 = fromIntegral $ (n .&. 0x3F) + 0x80
2422+
2423+ord4 :: Char -> [Word8]
2424+ord4 c = assert (n >= 0x10000) [x1, x2, x3, x4]
2425+ where
2426+ n = ord c
2427+ x1 = fromIntegral $ (n `shiftR` 18) + 0xF0
2428+ x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80
2429+ x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80
2430+ x4 = fromIntegral $ (n .&. 0x3F) + 0x80
2431+
2432+{-# INLINE chr2 #-}
2433+chr2 :: Word8 -> Word8 -> Char
2434+chr2 (W8# x1#) (W8# x2#) = C# (chr# (z1# +# z2#))
2435+ where
2436+ !y1# = word2Int# x1#
2437+ !y2# = word2Int# x2#
2438+ !z1# = uncheckedIShiftL# (y1# -# 192#) 6#
2439+ !z2# = y2# -# 128#
2440+
2441+{-# INLINE chr3 #-}
2442+chr3 :: Word8 -> Word8 -> Word8 -> Char
2443+chr3 (W8# x1#) (W8# x2#) (W8# x3#) = C# (chr# (z1# +# z2# +# z3#))
2444+ where
2445+ !y1# = word2Int# x1#
2446+ !y2# = word2Int# x2#
2447+ !y3# = word2Int# x3#
2448+ !z1# = uncheckedIShiftL# (y1# -# 224#) 12#
2449+ !z2# = uncheckedIShiftL# (y2# -# 128#) 6#
2450+ !z3# = y3# -# 128#
2451+
2452+{-# INLINE chr4 #-}
2453+chr4 :: Word8 -> Word8 -> Word8 -> Word8 -> Char
2454+chr4 (W8# x1#) (W8# x2#) (W8# x3#) (W8# x4#) =
2455+ C# (chr# (z1# +# z2# +# z3# +# z4#))
2456+ where
2457+ !y1# = word2Int# x1#
2458+ !y2# = word2Int# x2#
2459+ !y3# = word2Int# x3#
2460+ !y4# = word2Int# x4#
2461+ !z1# = uncheckedIShiftL# (y1# -# 240#) 18#
2462+ !z2# = uncheckedIShiftL# (y2# -# 128#) 12#
2463+ !z3# = uncheckedIShiftL# (y3# -# 128#) 6#
2464+ !z4# = y4# -# 128#
2465+
2466+{-# INLINE between #-}
2467+between ::
2468+ Word8 -- ^ byte to check
2469+ -> Word8 -- ^ lower bound
2470+ -> Word8 -- ^ upper bound
2471+ -> Bool
2472+between x y z = x >= y && x <= z
2473+
2474+{-# INLINE validate3 #-}
2475+validate3 :: Word8 -> Word8 -> Word8 -> Bool
2476+validate3 x1 x2 x3 = validate3_1 ||
2477+ validate3_2 ||
2478+ validate3_3 ||
2479+ validate3_4
2480+ where
2481+ validate3_1 = (x1 == 0xE0) &&
2482+ between x2 0xA0 0xBF &&
2483+ between x3 0x80 0xBF
2484+ validate3_2 = between x1 0xE1 0xEC &&
2485+ between x2 0x80 0xBF &&
2486+ between x3 0x80 0xBF
2487+ validate3_3 = x1 == 0xED &&
2488+ between x2 0x80 0x9F &&
2489+ between x3 0x80 0xBF
2490+ validate3_4 = between x1 0xEE 0xEF &&
2491+ between x2 0x80 0xBF &&
2492+ between x3 0x80 0xBF
2493+
2494+{-# INLINE validate4 #-}
2495+validate4 :: Word8 -> Word8 -> Word8 -> Word8 -> Bool
2496+validate4 x1 x2 x3 x4 = validate4_1 ||
2497+ validate4_2 ||
2498+ validate4_3
2499+ where
2500+ validate4_1 = x1 == 0xF0 &&
2501+ between x2 0x90 0xBF &&
2502+ between x3 0x80 0xBF &&
2503+ between x4 0x80 0xBF
2504+ validate4_2 = between x1 0xF1 0xF3 &&
2505+ between x2 0x80 0xBF &&
2506+ between x3 0x80 0xBF &&
2507+ between x4 0x80 0xBF
2508+ validate4_3 = x1 == 0xF4 &&
2509+ between x2 0x80 0x8F &&
2510+ between x3 0x80 0xBF &&
2511+ between x4 0x80 0xBF
2512+
2513+data CodePoint = FreshPoint
2514+ | Two !Word8
2515+ | GoThree !Word8
2516+ | Three !Word8 !Word8
2517+ | GoFour !Word8
2518+ | Four1 !Word8 !Word8
2519+ | Four !Word8 !Word8 !Word8
2520+ | YieldPoint !Char
2521+
2522+{-# INLINE_NORMAL decodeUtf8 #-}
2523+decodeUtf8 :: Monad m => Stream m Word8 -> Stream m Char
2524+decodeUtf8 (Stream step state) = Stream step' (state, FreshPoint)
2525+ where
2526+ {-# INLINE_LATE step' #-}
2527+ step' gst (st, FreshPoint) = do
2528+ r <- step (adaptState gst) st
2529+ return $
2530+ case r of
2531+ Yield c0 s
2532+ | c0 <= 0x7f ->
2533+ Skip (s, YieldPoint $ unsafeChr (fromIntegral c0))
2534+ | c0 >= 0xc0 && c0 <= 0xc1 -> error "Invalid Overlong forms"
2535+ | c0 >= 0xc2 && c0 <= 0xdf -> Skip (s, Two c0)
2536+ | c0 >= 0xe0 && c0 <= 0xef -> Skip (s, GoThree c0)
2537+ | c0 >= 0xf0 -> Skip (s, GoFour c0)
2538+ | otherwise -> error "Invalid Sequence"
2539+ Skip s -> Skip (s, FreshPoint)
2540+ Stop -> Stop
2541+
2542+ -- Decoding of a UTF8 character that spans two bytes with one byte (c0)
2543+ -- known.
2544+ step' gst (st, Two c0) = do
2545+ r <- step (adaptState gst) st
2546+ return $
2547+ case r of
2548+ Yield c1 s
2549+ | c1 < 0x80 || c1 >= 0xc0 -> error "Invalid Sequence"
2550+ | otherwise -> Skip (s, YieldPoint $ chr2 c0 c1)
2551+ Skip s -> Skip (s, Two c0)
2552+ Stop -> error "Input Underflow"
2553+
2554+ -- Decoding of a UTF8 character that spans three bytes with first byte (c0)
2555+ -- known.
2556+ step' gst (st, GoThree c0) = do
2557+ r <- step (adaptState gst) st
2558+ return $
2559+ case r of
2560+ Yield c1 s
2561+ | not (validate3 c0 c1 0x80) -> error "Invalid Sequence"
2562+ -- See #3341@ghc
2563+ | otherwise -> Skip (s, Three c0 c1)
2564+ Skip s -> Skip (s, GoThree c0)
2565+ Stop -> error "Input Underflow"
2566+
2567+ -- Two bytes known of a 3 byte UTF8 encoded unicode character.
2568+ step' gst (st, Three c0 c1) = do
2569+ r <- step (adaptState gst) st
2570+ return $
2571+ case r of
2572+ Yield c2 s
2573+ | not (validate3 c0 c1 c2) -> error "Invalid Sequence"
2574+ | otherwise -> Skip (s, YieldPoint $ chr3 c0 c1 c2)
2575+ Skip s -> Skip (s, Three c0 c1)
2576+ Stop -> error "Input Underflow"
2577+
2578+ -- One byte known of a four byte UTF8 unicode character.
2579+ step' gst (st, GoFour c0) = do
2580+ r <- step (adaptState gst) st
2581+ return $
2582+ case r of
2583+ Yield c1 s
2584+ | not (validate4 c0 c1 0x80 0x80) -> error "Invalid Sequence"
2585+ | otherwise -> Skip (s, Four1 c0 c1)
2586+ Skip s -> Skip (s, GoFour c0)
2587+ Stop -> error "Input Underflow"
2588+
2589+ -- Two bytes known of a four byte UTF8 unicode character.
2590+ step' gst (st, Four1 c0 c1) = do
2591+ r <- step (adaptState gst) st
2592+ return $
2593+ case r of
2594+ Yield c2 s
2595+ | not (validate4 c0 c1 c2 0x80) -> error "Invalid Sequence"
2596+ | otherwise -> Skip (s, Four c0 c1 c2)
2597+ Skip s -> Skip (s, Four1 c0 c1)
2598+ Stop -> error "Input Underflow"
2599+
2600+ -- Three bytes known of a three byte UTF8 unicode character.
2601+ step' gst (st, Four c0 c1 c2) = do
2602+ r <- step (adaptState gst) st
2603+ return $
2604+ case r of
2605+ Yield c3 s
2606+ | not (validate4 c0 c1 c2 c3) -> error "Invalid Sequence"
2607+ | otherwise -> Skip (s, YieldPoint $ chr4 c0 c1 c2 c3)
2608+ Skip s -> Skip (s, Four c0 c1 c2)
2609+ Stop -> error "Input Underflow"
2610+
2611+ -- This way so that we only need one Yield.
2612+ step' _ (s, YieldPoint c) = return $ Yield c (s, FreshPoint)
2613+
2614+data YieldMany x = None
2615+ | YieldMany !x
2616+
2617+{-# INLINE_NORMAL encodeUtf8 #-}
2618+encodeUtf8 :: Monad m => Stream m Char -> Stream m Word8
2619+encodeUtf8 (Stream step state) = Stream step' (state, None)
2620+ where
2621+ {-# INLINE_LATE step' #-}
2622+ step' gst (st, None) = do
2623+ r <- step (adaptState gst) st
2624+ return $
2625+ case r of
2626+ Yield c s ->
2627+ case ord c of
2628+ x | x <= 0x7F -> Skip (s, YieldMany [fromIntegral x])
2629+ | x <= 0x7FF -> Skip (s, YieldMany (ord2 c))
2630+ | x <= 0xFFFF ->
2631+ if isSurrogate c
2632+ then error "Encountered a surrogate"
2633+ else Skip (s, YieldMany (ord3 c))
2634+ | otherwise -> Skip (s, YieldMany (ord4 c))
2635+ Skip s -> Skip (s, None)
2636+ Stop -> Stop
2637+ step' _ (s, YieldMany []) = return $ Skip (s, None)
2638+ step' _ (s, YieldMany (x:xs)) = return $ Yield x (s, YieldMany xs)