git.iko.soy/streamly
on master help sign in
Refactor StreamD's splitting & grouping ops to SplitGroup module.
50929ccPranay Sashank
src/Streamly/Internal/Data/Stream/StreamD.hs+1−962
compare with master
unifiedsplit
@@ -312,11 +312,9 @@ import Control.Monad.Trans.Reader (ReaderT)
312import Control.Monad.Trans.State.Strict (StateT)
312import Control.Monad.Trans.State.Strict (StateT)
313import Control.Monad.Trans.Class (MonadTrans(lift))
313import Control.Monad.Trans.Class (MonadTrans(lift))
314import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_, control)
314import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_, control)
315−import Data.Bits (shiftR, shiftL, (.|.), (.&.))
316import Data.Functor.Identity (Identity(..))
315import Data.Functor.Identity (Identity(..))
317import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef)
316import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef)
318import Data.Maybe (fromJust, isJust)
317import Data.Maybe (fromJust, isJust)
319−import Data.Word (Word32)
320import Foreign.Storable (Storable(..))
318import Foreign.Storable (Storable(..))
321import GHC.Exts (SpecConstrAnnotation(..))
319import GHC.Exts (SpecConstrAnnotation(..))
322import GHC.Types (SPEC(..))
320import GHC.Types (SPEC(..))
@@ -324,7 +322,6 @@ import Fusion.Plugin.Types (Fuse(..))
324import Streamly.Internal.Data.Time.Units
322import Streamly.Internal.Data.Time.Units
325 (TimeUnit64, toRelTime64, diffAbsTime64)
323 (TimeUnit64, toRelTime64, diffAbsTime64)
326import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)
324import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)
327−import Streamly.Internal.Data.Array.Storable.Foreign.Types (Array(..))
328import Streamly.Internal.Data.Fold.Types (Fold(..))
325import Streamly.Internal.Data.Fold.Types (Fold(..))
329import Streamly.Internal.Data.Parser (ParseError(..))
326import Streamly.Internal.Data.Parser (ParseError(..))
330import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
327import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
@@ -336,7 +333,6 @@ import qualified Streamly.Internal.Data.IORef.Prim as Prim
336import qualified Streamly.Internal.Data.Pipe.Types as Pipe
333import qualified Streamly.Internal.Data.Pipe.Types as Pipe
337import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as A
334import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as A
338import qualified Streamly.Internal.Data.Fold as FL
335import qualified Streamly.Internal.Data.Fold as FL
339−import qualified Streamly.Memory.Ring as RB
340import qualified Streamly.Internal.Data.Stream.StreamK as K
336import qualified Streamly.Internal.Data.Stream.StreamK as K
341import qualified Streamly.Internal.Data.Parser as PR
337import qualified Streamly.Internal.Data.Parser as PR
342import qualified Streamly.Internal.Data.Parser.ParserD as PRD
338import qualified Streamly.Internal.Data.Parser.ParserD as PRD
@@ -353,6 +349,7 @@ import Prelude hiding
353 , reverse, iterate, splitAt)
349 , reverse, iterate, splitAt)
354import Streamly.Internal.Data.Stream.StreamD.Type
350import Streamly.Internal.Data.Stream.StreamD.Type
355import Streamly.Internal.Data.Stream.StreamD.Generate
351import Streamly.Internal.Data.Stream.StreamD.Generate
352+import Streamly.Internal.Data.Stream.StreamD.SplitGroup
356import Streamly.Internal.Data.SVar
353import Streamly.Internal.Data.SVar
357
354
358------------------------------------------------------------------------------
355------------------------------------------------------------------------------
@@ -1152,964 +1149,6 @@ reverse' m =
1152 $ toStreamK
1149 $ toStreamK
1153 $ A.fromStreamDArraysOf A.defaultChunkSize m
1150 $ A.fromStreamDArraysOf A.defaultChunkSize m
1154
1151
1155−
1156−------------------------------------------------------------------------------
1157−-- Grouping/Splitting
1158−------------------------------------------------------------------------------
1159−
1160−{-# INLINE_NORMAL groupsBy #-}
1161−groupsBy :: Monad m
1162− => (a -> a -> Bool)
1163− -> Fold m a b
1164− -> Stream m a
1165− -> Stream m b
1166−groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
1167−
1168− where
1169−
1170− {-# INLINE_LATE stepOuter #-}
1171− stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1172− res <- step (adaptState gst) st
1173− case res of
1174− Yield x s -> do
1175− fs <- initial
1176− r <- fstep fs x
1177− case r of
1178− FL.Partial fs1 -> go SPEC x s fs1
1179− FL.Done b -> return $ Yield b (Just s, Just x)
1180− Skip s -> return $ Skip (Just s, Nothing)
1181− Stop -> return Stop
1182−
1183− where
1184−
1185− go !_ prev stt !acc = do
1186− res <- step (adaptState gst) stt
1187− case res of
1188− Yield x s -> do
1189− if cmp x prev
1190− then do
1191− r <- fstep acc x
1192− case r of
1193− FL.Partial fs1 -> go SPEC prev s fs1
1194− FL.Done b -> return $ Yield b (Just s, Just x)
1195− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1196− Skip s -> go SPEC prev s acc
1197− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1198− stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
1199− fs <- initial
1200− r <- fstep fs prev
1201− case r of
1202− FL.Partial fs1 -> go SPEC st fs1
1203− FL.Done b -> return $ Yield b (Just st, Nothing)
1204−
1205− where
1206−
1207− -- XXX code duplicated from the previous equation
1208− go !_ stt !acc = do
1209− res <- step (adaptState gst) stt
1210− case res of
1211− Yield x s -> do
1212− if cmp x prev
1213− then do
1214− r <- fstep acc x
1215− case r of
1216− FL.Partial fs1 -> go SPEC s fs1
1217− FL.Done b -> return $ Yield b (Just s, Just x)
1218− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1219− Skip s -> go SPEC s acc
1220− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1221− stepOuter _ _ (Nothing, _) = return Stop
1222−
1223−{-# INLINE_NORMAL groupsRollingBy #-}
1224−groupsRollingBy :: Monad m
1225− => (a -> a -> Bool)
1226− -> Fold m a b
1227− -> Stream m a
1228− -> Stream m b
1229−groupsRollingBy cmp f (Stream step state) =
1230− Stream (stepOuter f) (Just state, Nothing)
1231−
1232− where
1233−
1234− {-# INLINE_LATE stepOuter #-}
1235− stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
1236− res <- step (adaptState gst) st
1237− case res of
1238− Yield x s -> do
1239− fs <- initial
1240− r <- fstep fs x
1241− case r of
1242− FL.Partial fs1 -> go SPEC x s fs1
1243− FL.Done b -> return $ Yield b (Just s, Just x)
1244− Skip s -> return $ Skip $ (Just s, Nothing)
1245− Stop -> return Stop
1246−
1247− where
1248−
1249− go !_ prev stt !acc = do
1250− res <- step (adaptState gst) stt
1251− case res of
1252− Yield x s -> do
1253− if cmp prev x
1254− then do
1255− r <- fstep acc x
1256− case r of
1257− FL.Partial fs1 -> go SPEC x s fs1
1258− FL.Done b -> return $ Yield b (Just s, Just x)
1259− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1260− Skip s -> go SPEC prev s acc
1261− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1262− stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
1263− fs <- initial
1264− r <- fstep fs prev'
1265− case r of
1266− FL.Partial fs1 -> go SPEC prev' st fs1
1267− FL.Done b -> return $ Yield b (Just st, Nothing)
1268−
1269− where
1270−
1271− go !_ prevv stt !acc = do
1272− res <- step (adaptState gst) stt
1273− case res of
1274− Yield x s -> do
1275− if cmp prevv x
1276− then do
1277− r <- fstep acc x
1278− case r of
1279− FL.Partial fs1 -> go SPEC x s fs1
1280− FL.Done b -> return $ Yield b (Just s, Just x)
1281− else done acc >>= \r -> return $ Yield r (Just s, Just x)
1282− Skip s -> go SPEC prevv s acc
1283− Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
1284− stepOuter _ _ (Nothing, _) = return Stop
1285−
1286−data WordsByState s = WordsByJust s | WordsByNothing
1287−
1288−{-# INLINE_NORMAL wordsBy #-}
1289−wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
1290−wordsBy predicate f (Stream step state) =
1291− Stream (stepOuter f) (WordsByJust state)
1292−
1293− where
1294−
1295− {-# INLINE_LATE stepOuter #-}
1296− stepOuter (Fold fstep initial done) gst (WordsByJust st) = do
1297− res <- step (adaptState gst) st
1298− case res of
1299− Yield x s -> do
1300− if predicate x
1301− then return $ Skip (WordsByJust s)
1302− else do
1303− fs <- initial
1304− r <- fstep fs x
1305− case r of
1306− FL.Partial fs1 -> go SPEC s fs1
1307− FL.Done b -> return $ Yield b (WordsByJust s)
1308−
1309− Skip s -> return $ Skip $ WordsByJust s
1310− Stop -> return Stop
1311−
1312− where
1313−
1314− go !_ stt !acc = do
1315− res <- step (adaptState gst) stt
1316− case res of
1317− Yield x s -> do
1318− if predicate x
1319− then done acc >>= \r -> return $ Yield r (WordsByJust s)
1320− else do
1321− r <- fstep acc x
1322− case r of
1323− FL.Partial fs1 -> go SPEC s fs1
1324− FL.Done b -> return $ Yield b (WordsByJust s)
1325− Skip s -> go SPEC s acc
1326− Stop -> done acc >>= \r -> return $ Yield r WordsByNothing
1327−
1328− stepOuter _ _ WordsByNothing = return Stop
1329−
1330−-- String search algorithms:
1331−-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
1332−
1333−{-
1334−-- TODO can we unify the splitting operations using a splitting configuration
1335−-- like in the split package.
1336−--
1337−data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
1338−
1339−data SplitOptions = SplitOptions
1340− { style :: SplitStyle
1341− , withSep :: Bool -- ^ keep the separators in output
1342− -- , compact :: Bool -- ^ treat multiple consecutive separators as one
1343− -- , trimHead :: Bool -- ^ drop blank at head
1344− -- , trimTail :: Bool -- ^ drop blank at tail
1345− }
1346−-}
1347−
1348−{-# ANN type SplitOnSeqState Fuse #-}
1349−data SplitOnSeqState rb rh ck w fs s b x =
1350− SplitOnSeqInit
1351− | SplitOnSeqYield b (SplitOnSeqState rb rh ck w fs s b x)
1352− | SplitOnSeqDone
1353−
1354− | SplitOnSeqEmpty s
1355−
1356− | SplitOnSeqSingle !fs s x
1357−
1358− | SplitOnSeqWordInit s
1359− | SplitOnSeqWordLoop !w s !fs
1360− | SplitOnSeqWordDone Int !fs !w
1361−
1362− | SplitOnSeqKRInit Int s rb !rh
1363− | SplitOnSeqKRLoop fs s rb !rh !ck
1364− | SplitOnSeqKRCheck fs s rb !rh
1365− | SplitOnSeqKRDone Int !fs rb !rh
1366−
1367−{-# INLINE_NORMAL splitOnSeq #-}
1368−splitOnSeq
1369− :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1370− => Array a
1371− -> Fold m a b
1372− -> Stream m a
1373− -> Stream m b
1374−splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
1375− Stream stepOuter SplitOnSeqInit
1376−
1377− where
1378−
1379− patLen = A.length patArr
1380− maxIndex = patLen - 1
1381− elemBits = sizeOf (undefined :: a) * 8
1382−
1383− -- For word pattern case
1384− wordMask :: Word
1385− wordMask = (1 `shiftL` (elemBits * patLen)) - 1
1386−
1387− elemMask :: Word
1388− elemMask = (1 `shiftL` elemBits) - 1
1389−
1390− wordPat :: Word
1391− wordPat = wordMask .&. A.foldl' addToWord 0 patArr
1392−
1393− addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1394−
1395− -- For Rabin-Karp search
1396− k = 2891336453 :: Word32
1397− coeff = k ^ patLen
1398−
1399− addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1400−
1401− deltaCksum cksum old new =
1402− addCksum cksum new - coeff * fromIntegral (fromEnum old)
1403−
1404− -- XXX shall we use a random starting hash or 1 instead of 0?
1405− patHash = A.foldl' addCksum 0 patArr
1406−
1407− skip = return . Skip
1408−
1409− {-# INLINE_LATE stepOuter #-}
1410− stepOuter _ SplitOnSeqInit =
1411− if patLen == 0
1412− then return $ Skip $ SplitOnSeqEmpty state
1413− else if patLen == 1
1414− then do
1415− acc <- initial
1416− pat <- liftIO $ A.unsafeIndexIO patArr 0
1417− return $ Skip $ SplitOnSeqSingle acc state pat
1418− else if sizeOf (undefined :: a) * patLen
1419− <= sizeOf (undefined :: Word)
1420− then return $ Skip $ SplitOnSeqWordInit state
1421− else do
1422− (rb, rhead) <- liftIO $ RB.new patLen
1423− skip $ SplitOnSeqKRInit 0 state rb rhead
1424−
1425− stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next
1426−
1427− ---------------------------
1428− -- Empty pattern
1429− ---------------------------
1430−
1431− stepOuter gst (SplitOnSeqEmpty st) = do
1432− res <- step (adaptState gst) st
1433− case res of
1434− Yield x s -> do
1435− fs <- initial
1436− r <- fstep fs x
1437− case r of
1438− FL.Partial fs1 -> do
1439− b <- done fs1
1440− skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
1441− FL.Done b -> skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
1442−
1443− Skip s -> return $ Skip (SplitOnSeqEmpty s)
1444− Stop -> return Stop
1445−
1446− -----------------
1447− -- Done
1448− -----------------
1449−
1450− stepOuter _ SplitOnSeqDone = return Stop
1451−
1452− -----------------
1453− -- Single Pattern
1454− -----------------
1455−
1456− stepOuter gst (SplitOnSeqSingle fs st pat) = do
1457− res <- step (adaptState gst) st
1458− case res of
1459− Yield x s -> do
1460− if pat == x
1461− then do
1462− r <- done fs
1463− fs1 <- initial
1464− return $ Skip $ SplitOnSeqYield r (SplitOnSeqSingle fs1 s pat)
1465− else do
1466− r <- fstep fs x
1467− case r of
1468− FL.Partial fs1 -> skip $ SplitOnSeqSingle fs1 s pat
1469− FL.Done b -> do
1470− fs1 <- initial
1471− skip $ SplitOnSeqYield b (SplitOnSeqSingle fs1 s pat)
1472− Skip s -> return $ Skip $ SplitOnSeqSingle fs s pat
1473− Stop -> do
1474− r <- done fs
1475− return $ Skip $ SplitOnSeqYield r SplitOnSeqDone
1476−
1477− ---------------------------
1478− -- Short Pattern - Shift Or
1479− ---------------------------
1480−
1481− stepOuter _ (SplitOnSeqWordDone 0 fs _) = do
1482− r <- done fs
1483− skip $ SplitOnSeqYield r SplitOnSeqDone
1484− stepOuter _ (SplitOnSeqWordDone n fs wrd) = do
1485− let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1)))
1486− r <- fstep fs (toEnum $ fromIntegral old)
1487− case r of
1488− FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd
1489− FL.Done b -> do
1490− fs1 <- initial
1491− let next = SplitOnSeqWordDone (n - 1) fs1 wrd
1492− skip $ SplitOnSeqYield b next
1493−
1494− stepOuter gst (SplitOnSeqWordInit st0) =
1495− go SPEC 0 0 st0
1496−
1497− where
1498−
1499− {-# INLINE go #-}
1500− go !_ !idx !wrd !st = do
1501− res <- step (adaptState gst) st
1502− case res of
1503− Yield x s -> do
1504− let wrd1 = addToWord wrd x
1505− if idx == maxIndex
1506− then do
1507− fs <- initial
1508− if wrd1 .&. wordMask == wordPat
1509− then do
1510− r <- done fs
1511− let next = SplitOnSeqWordInit s
1512− skip $ SplitOnSeqYield r next
1513− else skip $ SplitOnSeqWordLoop wrd1 s fs
1514− else go SPEC (idx + 1) wrd1 s
1515− Skip s -> go SPEC idx wrd s
1516− Stop -> do
1517− fs <- initial
1518− if idx /= 0
1519− then skip $ SplitOnSeqWordDone idx fs wrd
1520− else do
1521− r <- done fs
1522− skip $ SplitOnSeqYield r SplitOnSeqDone
1523−
1524− stepOuter gst (SplitOnSeqWordLoop wrd0 st0 fs0) =
1525− go SPEC wrd0 st0 fs0
1526−
1527− where
1528−
1529− {-# INLINE go #-}
1530− go !_ !wrd !st !fs = do
1531− res <- step (adaptState gst) st
1532− case res of
1533− Yield x s -> do
1534− let wrd1 = addToWord wrd x
1535− old = (wordMask .&. wrd)
1536− `shiftR` (elemBits * (patLen - 1))
1537− r <- fstep fs (toEnum $ fromIntegral old)
1538− case r of
1539− FL.Partial fs1 -> do
1540− if wrd1 .&. wordMask == wordPat
1541− then do
1542− b <- done fs1
1543− let next = SplitOnSeqWordInit s
1544− skip $ SplitOnSeqYield b next
1545− else go SPEC wrd1 s fs1
1546− FL.Done b ->
1547− let next = SplitOnSeqWordInit s
1548− in skip $ SplitOnSeqYield b next
1549− Skip s -> go SPEC wrd s fs
1550− Stop -> skip $ SplitOnSeqWordDone patLen fs wrd
1551−
1552− -------------------------------
1553− -- General Pattern - Karp Rabin
1554− -------------------------------
1555−
1556− stepOuter gst (SplitOnSeqKRInit idx st rb rh) = do
1557− res <- step (adaptState gst) st
1558− case res of
1559− Yield x s -> do
1560− rh1 <- liftIO $ RB.unsafeInsert rb rh x
1561− if idx == maxIndex
1562− then do
1563− let fold = RB.unsafeFoldRing (RB.ringBound rb)
1564− let !ringHash = fold addCksum 0 rb
1565− fs <- initial
1566− if ringHash == patHash
1567− then skip $ SplitOnSeqKRCheck fs s rb rh1
1568− else skip $ SplitOnSeqKRLoop fs s rb rh1 ringHash
1569− else skip $ SplitOnSeqKRInit (idx + 1) s rb rh1
1570− Skip s -> skip $ SplitOnSeqKRInit idx s rb rh
1571− Stop -> do
1572− fs <- initial
1573− skip $ SplitOnSeqKRDone idx fs rb (RB.startOf rb)
1574−
1575− -- XXX The recursive "go" is more efficient than the state based recursion
1576− -- code commented out below. Perhaps its more efficient because of
1577− -- factoring out "rb" outside the loop.
1578− --
1579− stepOuter gst (SplitOnSeqKRLoop fs0 st0 rb rh0 cksum0) =
1580− go SPEC fs0 st0 rh0 cksum0
1581−
1582− where
1583−
1584− go !_ !fs !st !rh !cksum = do
1585− res <- step (adaptState gst) st
1586− case res of
1587− Yield x s -> do
1588− old <- liftIO $ peek rh
1589− let cksum1 = deltaCksum cksum old x
1590− r <- fstep fs old
1591− case r of
1592− FL.Partial fs1 -> do
1593− rh1 <- liftIO (RB.unsafeInsert rb rh x)
1594− if cksum1 == patHash
1595− then skip $ SplitOnSeqKRCheck fs1 s rb rh1
1596− else go SPEC fs1 s rh1 cksum1
1597− FL.Done b ->
1598− let next = SplitOnSeqKRInit 0 s rb (RB.startOf rb)
1599− in skip $ SplitOnSeqYield b next
1600− Skip s -> go SPEC fs s rh cksum
1601− Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
1602−
1603− -- XXX The following code is 5 times slower compared to the recursive loop
1604− -- based code above. Need to investigate why. One possibility is that the
1605− -- go loop above does not thread around the ring buffer (rb). This code may
1606− -- be causing the state to bloat and getting allocated on each iteration.
1607− -- We can check the cmm/asm code to confirm. If so a good GHC solution to
1608− -- such problem is needed. One way to avoid this could be to use unboxed
1609− -- mutable state?
1610− {-
1611− stepOuter gst (SplitOnSeqKRLoop fs st rb rh cksum) = do
1612− res <- step (adaptState gst) st
1613− case res of
1614− Yield x s -> do
1615− old <- liftIO $ peek rh
1616− let cksum1 = deltaCksum cksum old x
1617− fs1 <- fstep fs old
1618− if (cksum1 == patHash)
1619− then do
1620− r <- done fs1
1621− skip $ SplitOnSeqYield r $ SplitOnSeqKRInit 0 s rb rh
1622− else do
1623− rh1 <- liftIO (RB.unsafeInsert rb rh x)
1624− skip $ SplitOnSeqKRLoop fs1 s rb rh1 cksum1
1625− Skip s -> skip $ SplitOnSeqKRLoop fs s rb rh cksum
1626− Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
1627− -}
1628−
1629− stepOuter _ (SplitOnSeqKRCheck fs st rb rh) = do
1630− if RB.unsafeEqArray rb rh patArr
1631− then do
1632− r <- done fs
1633− let next = SplitOnSeqKRInit 0 st rb (RB.startOf rb)
1634− skip $ SplitOnSeqYield r next
1635− else skip $ SplitOnSeqKRLoop fs st rb rh patHash
1636− stepOuter _ (SplitOnSeqKRDone 0 fs _ _) = do
1637− r <- done fs
1638− skip $ SplitOnSeqYield r SplitOnSeqDone
1639− stepOuter _ (SplitOnSeqKRDone n fs rb rh) = do
1640− old <- liftIO $ peek rh
1641− let rh1 = RB.advance rb rh
1642− r <- fstep fs old
1643− case r of
1644− FL.Partial fs1 -> skip $ SplitOnSeqKRDone (n - 1) fs1 rb rh1
1645− FL.Done b -> do
1646− fs1 <- initial
1647− let next = SplitOnSeqKRDone (n - 1) fs1 rb rh1
1648− skip $ SplitOnSeqYield b next
1649−
1650−{-# ANN type SplitOnSuffixSeqState Fuse #-}
1651−data SplitOnSuffixSeqState rb rh ck w fs s b x =
1652− SplitOnSuffixSeqInit
1653− | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState rb rh ck w fs s b x)
1654− | SplitOnSuffixSeqDone
1655−
1656− | SplitOnSuffixSeqEmpty s
1657−
1658− | SplitOnSuffixSeqSingleInit s x
1659− | SplitOnSuffixSeqSingle !fs s x
1660−
1661− | SplitOnSuffixSeqWordInit s
1662− | SplitOnSuffixSeqWordLoop !w s !fs
1663− | SplitOnSuffixSeqWordDone Int !fs !w
1664−
1665− | SplitOnSuffixSeqKRInit Int s rb !rh
1666− | SplitOnSuffixSeqKRInit1 !fs s rb !rh
1667− | SplitOnSuffixSeqKRLoop fs s rb !rh !ck
1668− | SplitOnSuffixSeqKRCheck fs s rb !rh
1669− | SplitOnSuffixSeqKRDone Int !fs rb !rh
1670−
1671−{-# INLINE_NORMAL splitOnSuffixSeq #-}
1672−splitOnSuffixSeq
1673− :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
1674− => Bool
1675− -> Array a
1676− -> Fold m a b
1677− -> Stream m a
1678− -> Stream m b
1679−splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
1680− Stream stepOuter SplitOnSuffixSeqInit
1681−
1682− where
1683−
1684− patLen = A.length patArr
1685− maxIndex = patLen - 1
1686− elemBits = sizeOf (undefined :: a) * 8
1687−
1688− -- For word pattern case
1689− wordMask :: Word
1690− wordMask = (1 `shiftL` (elemBits * patLen)) - 1
1691−
1692− elemMask :: Word
1693− elemMask = (1 `shiftL` elemBits) - 1
1694−
1695− wordPat :: Word
1696− wordPat = wordMask .&. A.foldl' addToWord 0 patArr
1697−
1698− addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
1699−
1700− -- For single element pattern case
1701− {-# INLINE processYieldSingle #-}
1702− processYieldSingle pat x s fs =
1703− if pat == x
1704− then do
1705− r <- if withSep then fstep fs x else return $ FL.Partial fs
1706− case r of
1707− FL.Partial fs1 -> do
1708− b <- done fs1
1709− let next = SplitOnSuffixSeqSingleInit s pat
1710− skip $ SplitOnSuffixSeqYield b next
1711− FL.Done b ->
1712− let next = SplitOnSuffixSeqSingleInit s pat
1713− in skip $ SplitOnSuffixSeqYield b next
1714− else do
1715− r <- fstep fs x
1716− case r of
1717− FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat
1718− FL.Done b ->
1719− let next = SplitOnSuffixSeqSingleInit s pat
1720− in skip $ SplitOnSuffixSeqYield b next
1721−
1722− -- For Rabin-Karp search
1723− k = 2891336453 :: Word32
1724− coeff = k ^ patLen
1725−
1726− addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
1727−
1728− deltaCksum cksum old new =
1729− addCksum cksum new - coeff * fromIntegral (fromEnum old)
1730−
1731− -- XXX shall we use a random starting hash or 1 instead of 0?
1732− patHash = A.foldl' addCksum 0 patArr
1733−
1734− skip = return . Skip
1735−
1736− {-# INLINE_LATE stepOuter #-}
1737− stepOuter _ SplitOnSuffixSeqInit =
1738− if patLen == 0
1739− then skip $ SplitOnSuffixSeqEmpty state
1740− else if patLen == 1
1741− then do
1742− pat <- liftIO $ A.unsafeIndexIO patArr 0
1743− skip $ SplitOnSuffixSeqSingleInit state pat
1744− else if sizeOf (undefined :: a) * patLen
1745− <= sizeOf (undefined :: Word)
1746− then skip $ SplitOnSuffixSeqWordInit state
1747− else do
1748− (rb, rhead) <- liftIO $ RB.new patLen
1749− skip $ SplitOnSuffixSeqKRInit 0 state rb rhead
1750−
1751− stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next
1752−
1753− ---------------------------
1754− -- Empty pattern
1755− ---------------------------
1756−
1757− stepOuter gst (SplitOnSuffixSeqEmpty st) = do
1758− res <- step (adaptState gst) st
1759− case res of
1760− Yield x s -> do
1761− acc <- initial
1762− r <- fstep acc x
1763− case r of
1764− FL.Partial fs -> do
1765− b <- done fs
1766− skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
1767− FL.Done b ->
1768− skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
1769− Skip s -> skip (SplitOnSuffixSeqEmpty s)
1770− Stop -> return Stop
1771−
1772− -----------------
1773− -- Done
1774− -----------------
1775−
1776− stepOuter _ SplitOnSuffixSeqDone = return Stop
1777−
1778− -----------------
1779− -- Single Pattern
1780− -----------------
1781−
1782− stepOuter gst (SplitOnSuffixSeqSingleInit st pat) = do
1783− res <- step (adaptState gst) st
1784− case res of
1785− Yield x s -> initial >>= processYieldSingle pat x s
1786− Skip s -> skip $ SplitOnSuffixSeqSingleInit s pat
1787− Stop -> return Stop
1788−
1789− stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do
1790− res <- step (adaptState gst) st
1791− case res of
1792− Yield x s -> processYieldSingle pat x s fs
1793− Skip s -> skip $ SplitOnSuffixSeqSingle fs s pat
1794− Stop -> do
1795− r <- done fs
1796− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1797−
1798− ---------------------------
1799− -- Short Pattern - Shift Or
1800− ---------------------------
1801−
1802− stepOuter _ (SplitOnSuffixSeqWordDone 0 fs _) = do
1803− r <- done fs
1804− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1805− stepOuter _ (SplitOnSuffixSeqWordDone n fs wrd) = do
1806− let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1)))
1807− r <- fstep fs (toEnum $ fromIntegral old)
1808− case r of
1809− FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
1810− FL.Done b -> do
1811− fs1 <- initial
1812− let next = SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
1813− skip $ SplitOnSuffixSeqYield b next
1814−
1815− stepOuter gst (SplitOnSuffixSeqWordInit st0) = do
1816− res <- step (adaptState gst) st0
1817− case res of
1818− Yield x s -> do
1819− fs <- initial
1820− let wrd = addToWord 0 x
1821− r <- if withSep then fstep fs x else return $ FL.Partial fs
1822− case r of
1823− FL.Partial fs1 -> go SPEC 1 wrd s fs1
1824− FL.Done b -> do
1825− let next = SplitOnSuffixSeqWordInit s
1826− in skip $ SplitOnSuffixSeqYield b next
1827− Skip s -> skip (SplitOnSuffixSeqWordInit s)
1828− Stop -> return Stop
1829−
1830− where
1831−
1832− {-# INLINE go #-}
1833− go !_ !idx !wrd !st !fs = do
1834− res <- step (adaptState gst) st
1835− case res of
1836− Yield x s -> do
1837− let wrd1 = addToWord wrd x
1838− r <- if withSep then fstep fs x else return $ FL.Partial fs
1839− case r of
1840− FL.Partial fs1 ->
1841− if idx /= maxIndex
1842− then go SPEC (idx + 1) wrd1 s fs1
1843− else if wrd1 .&. wordMask /= wordPat
1844− then skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1
1845− else do
1846− b <- done fs
1847− let next = SplitOnSuffixSeqWordInit s
1848− skip $ SplitOnSuffixSeqYield b next
1849− FL.Done b ->
1850− let next = SplitOnSuffixSeqWordInit s
1851− in skip $ SplitOnSuffixSeqYield b next
1852− Skip s -> go SPEC idx wrd s fs
1853− Stop -> skip $ SplitOnSuffixSeqWordDone idx fs wrd
1854−
1855− stepOuter gst (SplitOnSuffixSeqWordLoop wrd0 st0 fs0) =
1856− go SPEC wrd0 st0 fs0
1857−
1858− where
1859−
1860− {-# INLINE go #-}
1861− go !_ !wrd !st !fs = do
1862− res <- step (adaptState gst) st
1863− case res of
1864− Yield x s -> do
1865− let wrd1 = addToWord wrd x
1866− old = (wordMask .&. wrd)
1867− `shiftR` (elemBits * (patLen - 1))
1868− r <-
1869− if withSep
1870− then fstep fs x
1871− else fstep fs (toEnum $ fromIntegral old)
1872− case r of
1873− FL.Partial fs1 ->
1874− if wrd1 .&. wordMask == wordPat
1875− then do
1876− b <- done fs1
1877− let next = SplitOnSuffixSeqWordInit s
1878− skip $ SplitOnSuffixSeqYield b next
1879− else go SPEC wrd1 s fs1
1880− FL.Done b ->
1881− let next = SplitOnSuffixSeqWordInit s
1882− in skip $ SplitOnSuffixSeqYield b next
1883− Skip s -> go SPEC wrd s fs
1884− Stop ->
1885− if wrd .&. wordMask == wordPat
1886− then return Stop
1887− else if withSep
1888− then do
1889− r <- done fs
1890− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1891− else skip $ SplitOnSuffixSeqWordDone patLen fs wrd
1892−
1893− -------------------------------
1894− -- General Pattern - Karp Rabin
1895− -------------------------------
1896−
1897− stepOuter gst (SplitOnSuffixSeqKRInit idx0 st0 rb rh0) = do
1898− res <- step (adaptState gst) st0
1899− case res of
1900− Yield x s -> do
1901− rh1 <- liftIO $ RB.unsafeInsert rb rh0 x
1902− fs <- initial
1903− r <- if withSep then fstep fs x else return $ FL.Partial fs
1904− case r of
1905− FL.Partial fs1 ->
1906− skip $ SplitOnSuffixSeqKRInit1 fs1 s rb rh1
1907− FL.Done b ->
1908− let next = SplitOnSuffixSeqKRInit 0 s rb (RB.startOf rb)
1909− in skip $ SplitOnSuffixSeqYield b next
1910− Skip s -> skip $ SplitOnSuffixSeqKRInit idx0 s rb rh0
1911− Stop -> return Stop
1912−
1913− stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 rb rh0) = do
1914− go SPEC 1 rh0 st0 fs0
1915−
1916− where
1917−
1918− go !_ !idx !rh st !fs = do
1919− res <- step (adaptState gst) st
1920− case res of
1921− Yield x s -> do
1922− rh1 <- liftIO (RB.unsafeInsert rb rh x)
1923− r <- if withSep then fstep fs x else return $ FL.Partial fs
1924− case r of
1925− FL.Partial fs1 ->
1926− if idx /= maxIndex
1927− then go SPEC (idx + 1) rh1 s fs1
1928− else skip $
1929− let fold = RB.unsafeFoldRing (RB.ringBound rb)
1930− !ringHash = fold addCksum 0 rb
1931− in if ringHash == patHash
1932− then SplitOnSuffixSeqKRCheck fs1 s rb rh1
1933− else SplitOnSuffixSeqKRLoop
1934− fs1 s rb rh1 ringHash
1935− FL.Done b ->
1936− let next = SplitOnSuffixSeqKRInit
1937− 0 st rb (RB.startOf rb)
1938− in skip $ SplitOnSuffixSeqYield b next
1939− Skip s -> go SPEC idx rh s fs
1940− Stop -> do
1941− -- do not issue a blank segment when we end at pattern
1942− if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
1943− then return Stop
1944− else if withSep
1945− then do
1946− r <- done fs
1947− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1948− else skip $ SplitOnSuffixSeqKRDone idx fs rb (RB.startOf rb)
1949−
1950− stepOuter gst (SplitOnSuffixSeqKRLoop fs0 st0 rb rh0 cksum0) =
1951− go SPEC fs0 st0 rh0 cksum0
1952−
1953− where
1954−
1955− go !_ !fs !st !rh !cksum = do
1956− res <- step (adaptState gst) st
1957− case res of
1958− Yield x s -> do
1959− old <- liftIO $ peek rh
1960− rh1 <- liftIO (RB.unsafeInsert rb rh x)
1961− let cksum1 = deltaCksum cksum old x
1962− r <- if withSep then fstep fs x else fstep fs old
1963− case r of
1964− FL.Partial fs1 ->
1965− if (cksum1 /= patHash)
1966− then go SPEC fs1 s rh1 cksum1
1967− else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1
1968− FL.Done b ->
1969− let next = SplitOnSuffixSeqKRInit
1970− 0 st rb (RB.startOf rb)
1971− in skip $ SplitOnSuffixSeqYield b next
1972− Skip s -> go SPEC fs s rh cksum
1973− Stop ->
1974− if RB.unsafeEqArray rb rh patArr
1975− then return Stop
1976− else if withSep
1977− then do
1978− r <- done fs
1979− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1980− else skip $ SplitOnSuffixSeqKRDone patLen fs rb rh
1981−
1982− stepOuter _ (SplitOnSuffixSeqKRCheck fs st rb rh) = do
1983− if RB.unsafeEqArray rb rh patArr
1984− then do
1985− r <- done fs
1986− let next = SplitOnSuffixSeqKRInit 0 st rb (RB.startOf rb)
1987− skip $ SplitOnSuffixSeqYield r next
1988− else skip $ SplitOnSuffixSeqKRLoop fs st rb rh patHash
1989−
1990− stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _ _) = do
1991− r <- done fs
1992− skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
1993− stepOuter _ (SplitOnSuffixSeqKRDone n fs rb rh) = do
1994− old <- liftIO $ peek rh
1995− let rh1 = RB.advance rb rh
1996− r <- fstep fs old
1997− case r of
1998− FL.Partial fs1 -> skip $ SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
1999− FL.Done b -> do
2000− fs1 <- initial
2001− let next = SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
2002− skip $ SplitOnSuffixSeqYield b next
2003−
2004−{-# ANN type SplitState Fuse #-}
2005−data SplitState s arr
2006− = SplitInitial s
2007− | SplitBuffering s arr
2008− | SplitSplitting s arr
2009− | SplitYielding arr (SplitState s arr)
2010− | SplitFinishing
2011−
2012−-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
2013−-- split using a splitBy like combinator. The Fold would consume upto the
2014−-- separator and return any leftover which can then be fed to the next fold.
2015−--
2016−-- We can revisit this once we have partial folds/parsers.
2017−--
2018−-- | Performs infix separator style splitting.
2019−{-# INLINE_NORMAL splitInnerBy #-}
2020−splitInnerBy
2021− :: Monad m
2022− => (f a -> m (f a, Maybe (f a))) -- splitter
2023− -> (f a -> f a -> m (f a)) -- joiner
2024− -> Stream m (f a)
2025− -> Stream m (f a)
2026−splitInnerBy splitter joiner (Stream step1 state1) =
2027− (Stream step (SplitInitial state1))
2028−
2029− where
2030−
2031− {-# INLINE_LATE step #-}
2032− step gst (SplitInitial st) = do
2033− r <- step1 gst st
2034− case r of
2035− Yield x s -> do
2036− (x1, mx2) <- splitter x
2037− return $ case mx2 of
2038− Nothing -> Skip (SplitBuffering s x1)
2039− Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
2040− Skip s -> return $ Skip (SplitInitial s)
2041− Stop -> return $ Stop
2042−
2043− step gst (SplitBuffering st buf) = do
2044− r <- step1 gst st
2045− case r of
2046− Yield x s -> do
2047− (x1, mx2) <- splitter x
2048− buf' <- joiner buf x1
2049− return $ case mx2 of
2050− Nothing -> Skip (SplitBuffering s buf')
2051− Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
2052− Skip s -> return $ Skip (SplitBuffering s buf)
2053− Stop -> return $ Skip (SplitYielding buf SplitFinishing)
2054−
2055− step _ (SplitSplitting st buf) = do
2056− (x1, mx2) <- splitter buf
2057− return $ case mx2 of
2058− Nothing -> Skip $ SplitBuffering st x1
2059− Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
2060−
2061− step _ (SplitYielding x next) = return $ Yield x next
2062− step _ SplitFinishing = return $ Stop
2063−
2064−-- | Performs infix separator style splitting.
2065−{-# INLINE_NORMAL splitInnerBySuffix #-}
2066−splitInnerBySuffix
2067− :: (Monad m, Eq (f a), Monoid (f a))
2068− => (f a -> m (f a, Maybe (f a))) -- splitter
2069− -> (f a -> f a -> m (f a)) -- joiner
2070− -> Stream m (f a)
2071− -> Stream m (f a)
2072−splitInnerBySuffix splitter joiner (Stream step1 state1) =
2073− (Stream step (SplitInitial state1))
2074−
2075− where
2076−
2077− {-# INLINE_LATE step #-}
2078− step gst (SplitInitial st) = do
2079− r <- step1 gst st
2080− case r of
2081− Yield x s -> do
2082− (x1, mx2) <- splitter x
2083− return $ case mx2 of
2084− Nothing -> Skip (SplitBuffering s x1)
2085− Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
2086− Skip s -> return $ Skip (SplitInitial s)
2087− Stop -> return $ Stop
2088−
2089− step gst (SplitBuffering st buf) = do
2090− r <- step1 gst st
2091− case r of
2092− Yield x s -> do
2093− (x1, mx2) <- splitter x
2094− buf' <- joiner buf x1
2095− return $ case mx2 of
2096− Nothing -> Skip (SplitBuffering s buf')
2097− Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
2098− Skip s -> return $ Skip (SplitBuffering s buf)
2099− Stop -> return $
2100− if buf == mempty
2101− then Stop
2102− else Skip (SplitYielding buf SplitFinishing)
2103−
2104− step _ (SplitSplitting st buf) = do
2105− (x1, mx2) <- splitter buf
2106− return $ case mx2 of
2107− Nothing -> Skip $ SplitBuffering st x1
2108− Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
2109−
2110− step _ (SplitYielding x next) = return $ Yield x next
2111− step _ SplitFinishing = return $ Stop
2112−
2113------------------------------------------------------------------------------
1152------------------------------------------------------------------------------
2114-- Substreams
1153-- Substreams
2115------------------------------------------------------------------------------
1154------------------------------------------------------------------------------
src/Streamly/Internal/Data/Stream/StreamD/SplitGroup.hsnew file+1005
@@ -0,0 +1,1005 @@
1+#include "inline.hs"
2+
3+-- |
4+-- Module : Streamly.Internal.Data.Stream.StreamD.SplitGroup
5+-- Copyright : (c) 2020 Composewell Technologies
6+-- License : BSD-3-Clause
7+-- Maintainer : streamly@composewell.com
8+-- Stability : experimental
9+-- Portability : GHC
10+
11+module Streamly.Internal.Data.Stream.StreamD.SplitGroup
12+ (
13+ -- ** Grouping
14+ groupsOf2
15+ , groupsBy
16+ , groupsRollingBy
17+
18+ -- ** Splitting
19+ , wordsBy
20+
21+ , splitOnSeq
22+ , splitOnSuffixSeq
23+
24+ , splitInnerBy
25+ , splitInnerBySuffix
26+ )
27+where
28+
29+import Control.Monad.IO.Class (MonadIO(..))
30+import Data.Bits (shiftR, shiftL, (.|.), (.&.))
31+import Data.Word (Word32)
32+import Foreign.Storable (Storable(..))
33+import GHC.Types (SPEC(..))
34+import Fusion.Plugin.Types (Fuse(..))
35+import Streamly.Internal.Data.Array.Storable.Foreign.Types (Array(..))
36+import Streamly.Internal.Data.Fold.Types (Fold(..))
37+
38+import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as A
39+import qualified Streamly.Internal.Data.Fold as FL
40+import qualified Streamly.Memory.Ring as RB
41+
42+import Prelude hiding
43+ ( map, mapM, mapM_, repeat, foldr, last, take, filter
44+ , takeWhile, drop, dropWhile, all, any, maximum, minimum, elem
45+ , notElem, null, head, tail, zipWith, lookup, foldr1, sequence
46+ , (!!), scanl, scanl1, concatMap, replicate, enumFromTo, concat
47+ , reverse, iterate, splitAt)
48+import Streamly.Internal.Data.Stream.StreamD.Type
49+import Streamly.Internal.Data.SVar
50+
51+------------------------------------------------------------------------------
52+-- Grouping/Splitting
53+------------------------------------------------------------------------------
54+
55+{-# INLINE_NORMAL groupsBy #-}
56+groupsBy :: Monad m
57+ => (a -> a -> Bool)
58+ -> Fold m a b
59+ -> Stream m a
60+ -> Stream m b
61+groupsBy cmp f (Stream step state) = Stream (stepOuter f) (Just state, Nothing)
62+
63+ where
64+
65+ {-# INLINE_LATE stepOuter #-}
66+ stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
67+ res <- step (adaptState gst) st
68+ case res of
69+ Yield x s -> do
70+ fs <- initial
71+ r <- fstep fs x
72+ case r of
73+ FL.Partial fs1 -> go SPEC x s fs1
74+ FL.Done b -> return $ Yield b (Just s, Just x)
75+ Skip s -> return $ Skip (Just s, Nothing)
76+ Stop -> return Stop
77+
78+ where
79+
80+ go !_ prev stt !acc = do
81+ res <- step (adaptState gst) stt
82+ case res of
83+ Yield x s -> do
84+ if cmp x prev
85+ then do
86+ r <- fstep acc x
87+ case r of
88+ FL.Partial fs1 -> go SPEC prev s fs1
89+ FL.Done b -> return $ Yield b (Just s, Just x)
90+ else done acc >>= \r -> return $ Yield r (Just s, Just x)
91+ Skip s -> go SPEC prev s acc
92+ Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
93+ stepOuter (Fold fstep initial done) gst (Just st, Just prev) = do
94+ fs <- initial
95+ r <- fstep fs prev
96+ case r of
97+ FL.Partial fs1 -> go SPEC st fs1
98+ FL.Done b -> return $ Yield b (Just st, Nothing)
99+
100+ where
101+
102+ -- XXX code duplicated from the previous equation
103+ go !_ stt !acc = do
104+ res <- step (adaptState gst) stt
105+ case res of
106+ Yield x s -> do
107+ if cmp x prev
108+ then do
109+ r <- fstep acc x
110+ case r of
111+ FL.Partial fs1 -> go SPEC s fs1
112+ FL.Done b -> return $ Yield b (Just s, Just x)
113+ else done acc >>= \r -> return $ Yield r (Just s, Just x)
114+ Skip s -> go SPEC s acc
115+ Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
116+ stepOuter _ _ (Nothing, _) = return Stop
117+
118+{-# INLINE_NORMAL groupsRollingBy #-}
119+groupsRollingBy :: Monad m
120+ => (a -> a -> Bool)
121+ -> Fold m a b
122+ -> Stream m a
123+ -> Stream m b
124+groupsRollingBy cmp f (Stream step state) =
125+ Stream (stepOuter f) (Just state, Nothing)
126+
127+ where
128+
129+ {-# INLINE_LATE stepOuter #-}
130+ stepOuter (Fold fstep initial done) gst (Just st, Nothing) = do
131+ res <- step (adaptState gst) st
132+ case res of
133+ Yield x s -> do
134+ fs <- initial
135+ r <- fstep fs x
136+ case r of
137+ FL.Partial fs1 -> go SPEC x s fs1
138+ FL.Done b -> return $ Yield b (Just s, Just x)
139+ Skip s -> return $ Skip $ (Just s, Nothing)
140+ Stop -> return Stop
141+
142+ where
143+
144+ go !_ prev stt !acc = do
145+ res <- step (adaptState gst) stt
146+ case res of
147+ Yield x s -> do
148+ if cmp prev x
149+ then do
150+ r <- fstep acc x
151+ case r of
152+ FL.Partial fs1 -> go SPEC x s fs1
153+ FL.Done b -> return $ Yield b (Just s, Just x)
154+ else done acc >>= \r -> return $ Yield r (Just s, Just x)
155+ Skip s -> go SPEC prev s acc
156+ Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
157+ stepOuter (Fold fstep initial done) gst (Just st, Just prev') = do
158+ fs <- initial
159+ r <- fstep fs prev'
160+ case r of
161+ FL.Partial fs1 -> go SPEC prev' st fs1
162+ FL.Done b -> return $ Yield b (Just st, Nothing)
163+
164+ where
165+
166+ go !_ prevv stt !acc = do
167+ res <- step (adaptState gst) stt
168+ case res of
169+ Yield x s -> do
170+ if cmp prevv x
171+ then do
172+ r <- fstep acc x
173+ case r of
174+ FL.Partial fs1 -> go SPEC x s fs1
175+ FL.Done b -> return $ Yield b (Just s, Just x)
176+ else done acc >>= \r -> return $ Yield r (Just s, Just x)
177+ Skip s -> go SPEC prevv s acc
178+ Stop -> done acc >>= \r -> return $ Yield r (Nothing, Nothing)
179+ stepOuter _ _ (Nothing, _) = return Stop
180+
181+data WordsByState s = WordsByJust s | WordsByNothing
182+
183+{-# INLINE_NORMAL wordsBy #-}
184+wordsBy :: Monad m => (a -> Bool) -> Fold m a b -> Stream m a -> Stream m b
185+wordsBy predicate f (Stream step state) =
186+ Stream (stepOuter f) (WordsByJust state)
187+
188+ where
189+
190+ {-# INLINE_LATE stepOuter #-}
191+ stepOuter (Fold fstep initial done) gst (WordsByJust st) = do
192+ res <- step (adaptState gst) st
193+ case res of
194+ Yield x s -> do
195+ if predicate x
196+ then return $ Skip (WordsByJust s)
197+ else do
198+ fs <- initial
199+ r <- fstep fs x
200+ case r of
201+ FL.Partial fs1 -> go SPEC s fs1
202+ FL.Done b -> return $ Yield b (WordsByJust s)
203+
204+ Skip s -> return $ Skip $ WordsByJust s
205+ Stop -> return Stop
206+
207+ where
208+
209+ go !_ stt !acc = do
210+ res <- step (adaptState gst) stt
211+ case res of
212+ Yield x s -> do
213+ if predicate x
214+ then done acc >>= \r -> return $ Yield r (WordsByJust s)
215+ else do
216+ r <- fstep acc x
217+ case r of
218+ FL.Partial fs1 -> go SPEC s fs1
219+ FL.Done b -> return $ Yield b (WordsByJust s)
220+ Skip s -> go SPEC s acc
221+ Stop -> done acc >>= \r -> return $ Yield r WordsByNothing
222+
223+ stepOuter _ _ WordsByNothing = return Stop
224+
225+-- String search algorithms:
226+-- http://www-igm.univ-mlv.fr/~lecroq/string/index.html
227+
228+{-
229+-- TODO can we unify the splitting operations using a splitting configuration
230+-- like in the split package.
231+--
232+data SplitStyle = Infix | Suffix | Prefix deriving (Eq, Show)
233+data SplitOptions = SplitOptions
234+ { style :: SplitStyle
235+ , withSep :: Bool -- ^ keep the separators in output
236+ -- , compact :: Bool -- ^ treat multiple consecutive separators as one
237+ -- , trimHead :: Bool -- ^ drop blank at head
238+ -- , trimTail :: Bool -- ^ drop blank at tail
239+ }
240+-}
241+
242+{-# ANN type SplitOnSeqState Fuse #-}
243+data SplitOnSeqState rb rh ck w fs s b x =
244+ SplitOnSeqInit
245+ | SplitOnSeqYield b (SplitOnSeqState rb rh ck w fs s b x)
246+ | SplitOnSeqDone
247+
248+ | SplitOnSeqEmpty s
249+
250+ | SplitOnSeqSingle !fs s x
251+
252+ | SplitOnSeqWordInit s
253+ | SplitOnSeqWordLoop !w s !fs
254+ | SplitOnSeqWordDone Int !fs !w
255+
256+ | SplitOnSeqKRInit Int s rb !rh
257+ | SplitOnSeqKRLoop fs s rb !rh !ck
258+ | SplitOnSeqKRCheck fs s rb !rh
259+ | SplitOnSeqKRDone Int !fs rb !rh
260+
261+{-# INLINE_NORMAL splitOnSeq #-}
262+splitOnSeq
263+ :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
264+ => Array a
265+ -> Fold m a b
266+ -> Stream m a
267+ -> Stream m b
268+splitOnSeq patArr (Fold fstep initial done) (Stream step state) =
269+ Stream stepOuter SplitOnSeqInit
270+
271+ where
272+
273+ patLen = A.length patArr
274+ maxIndex = patLen - 1
275+ elemBits = sizeOf (undefined :: a) * 8
276+
277+ -- For word pattern case
278+ wordMask :: Word
279+ wordMask = (1 `shiftL` (elemBits * patLen)) - 1
280+
281+ elemMask :: Word
282+ elemMask = (1 `shiftL` elemBits) - 1
283+
284+ wordPat :: Word
285+ wordPat = wordMask .&. A.foldl' addToWord 0 patArr
286+
287+ addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
288+
289+ -- For Rabin-Karp search
290+ k = 2891336453 :: Word32
291+ coeff = k ^ patLen
292+
293+ addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
294+
295+ deltaCksum cksum old new =
296+ addCksum cksum new - coeff * fromIntegral (fromEnum old)
297+
298+ -- XXX shall we use a random starting hash or 1 instead of 0?
299+ patHash = A.foldl' addCksum 0 patArr
300+
301+ skip = return . Skip
302+
303+ {-# INLINE_LATE stepOuter #-}
304+ stepOuter _ SplitOnSeqInit =
305+ if patLen == 0
306+ then return $ Skip $ SplitOnSeqEmpty state
307+ else if patLen == 1
308+ then do
309+ acc <- initial
310+ pat <- liftIO $ A.unsafeIndexIO patArr 0
311+ return $ Skip $ SplitOnSeqSingle acc state pat
312+ else if sizeOf (undefined :: a) * patLen
313+ <= sizeOf (undefined :: Word)
314+ then return $ Skip $ SplitOnSeqWordInit state
315+ else do
316+ (rb, rhead) <- liftIO $ RB.new patLen
317+ skip $ SplitOnSeqKRInit 0 state rb rhead
318+
319+ stepOuter _ (SplitOnSeqYield x next) = return $ Yield x next
320+
321+ ---------------------------
322+ -- Empty pattern
323+ ---------------------------
324+
325+ stepOuter gst (SplitOnSeqEmpty st) = do
326+ res <- step (adaptState gst) st
327+ case res of
328+ Yield x s -> do
329+ fs <- initial
330+ r <- fstep fs x
331+ case r of
332+ FL.Partial fs1 -> do
333+ b <- done fs1
334+ skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
335+ FL.Done b -> skip $ SplitOnSeqYield b (SplitOnSeqEmpty s)
336+
337+ Skip s -> return $ Skip (SplitOnSeqEmpty s)
338+ Stop -> return Stop
339+
340+ -----------------
341+ -- Done
342+ -----------------
343+
344+ stepOuter _ SplitOnSeqDone = return Stop
345+
346+ -----------------
347+ -- Single Pattern
348+ -----------------
349+
350+ stepOuter gst (SplitOnSeqSingle fs st pat) = do
351+ res <- step (adaptState gst) st
352+ case res of
353+ Yield x s -> do
354+ if pat == x
355+ then do
356+ r <- done fs
357+ fs1 <- initial
358+ return $ Skip $ SplitOnSeqYield r (SplitOnSeqSingle fs1 s pat)
359+ else do
360+ r <- fstep fs x
361+ case r of
362+ FL.Partial fs1 -> skip $ SplitOnSeqSingle fs1 s pat
363+ FL.Done b -> do
364+ fs1 <- initial
365+ skip $ SplitOnSeqYield b (SplitOnSeqSingle fs1 s pat)
366+ Skip s -> return $ Skip $ SplitOnSeqSingle fs s pat
367+ Stop -> do
368+ r <- done fs
369+ return $ Skip $ SplitOnSeqYield r SplitOnSeqDone
370+
371+ ---------------------------
372+ -- Short Pattern - Shift Or
373+ ---------------------------
374+
375+ stepOuter _ (SplitOnSeqWordDone 0 fs _) = do
376+ r <- done fs
377+ skip $ SplitOnSeqYield r SplitOnSeqDone
378+ stepOuter _ (SplitOnSeqWordDone n fs wrd) = do
379+ let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1)))
380+ r <- fstep fs (toEnum $ fromIntegral old)
381+ case r of
382+ FL.Partial fs1 -> skip $ SplitOnSeqWordDone (n - 1) fs1 wrd
383+ FL.Done b -> do
384+ fs1 <- initial
385+ let next = SplitOnSeqWordDone (n - 1) fs1 wrd
386+ skip $ SplitOnSeqYield b next
387+
388+ stepOuter gst (SplitOnSeqWordInit st0) =
389+ go SPEC 0 0 st0
390+
391+ where
392+
393+ {-# INLINE go #-}
394+ go !_ !idx !wrd !st = do
395+ res <- step (adaptState gst) st
396+ case res of
397+ Yield x s -> do
398+ let wrd1 = addToWord wrd x
399+ if idx == maxIndex
400+ then do
401+ fs <- initial
402+ if wrd1 .&. wordMask == wordPat
403+ then do
404+ r <- done fs
405+ let next = SplitOnSeqWordInit s
406+ skip $ SplitOnSeqYield r next
407+ else skip $ SplitOnSeqWordLoop wrd1 s fs
408+ else go SPEC (idx + 1) wrd1 s
409+ Skip s -> go SPEC idx wrd s
410+ Stop -> do
411+ fs <- initial
412+ if idx /= 0
413+ then skip $ SplitOnSeqWordDone idx fs wrd
414+ else do
415+ r <- done fs
416+ skip $ SplitOnSeqYield r SplitOnSeqDone
417+
418+ stepOuter gst (SplitOnSeqWordLoop wrd0 st0 fs0) =
419+ go SPEC wrd0 st0 fs0
420+
421+ where
422+
423+ {-# INLINE go #-}
424+ go !_ !wrd !st !fs = do
425+ res <- step (adaptState gst) st
426+ case res of
427+ Yield x s -> do
428+ let wrd1 = addToWord wrd x
429+ old = (wordMask .&. wrd)
430+ `shiftR` (elemBits * (patLen - 1))
431+ r <- fstep fs (toEnum $ fromIntegral old)
432+ case r of
433+ FL.Partial fs1 -> do
434+ if wrd1 .&. wordMask == wordPat
435+ then do
436+ b <- done fs1
437+ let next = SplitOnSeqWordInit s
438+ skip $ SplitOnSeqYield b next
439+ else go SPEC wrd1 s fs1
440+ FL.Done b ->
441+ let next = SplitOnSeqWordInit s
442+ in skip $ SplitOnSeqYield b next
443+ Skip s -> go SPEC wrd s fs
444+ Stop -> skip $ SplitOnSeqWordDone patLen fs wrd
445+
446+ -------------------------------
447+ -- General Pattern - Karp Rabin
448+ -------------------------------
449+
450+ stepOuter gst (SplitOnSeqKRInit idx st rb rh) = do
451+ res <- step (adaptState gst) st
452+ case res of
453+ Yield x s -> do
454+ rh1 <- liftIO $ RB.unsafeInsert rb rh x
455+ if idx == maxIndex
456+ then do
457+ let fold = RB.unsafeFoldRing (RB.ringBound rb)
458+ let !ringHash = fold addCksum 0 rb
459+ fs <- initial
460+ if ringHash == patHash
461+ then skip $ SplitOnSeqKRCheck fs s rb rh1
462+ else skip $ SplitOnSeqKRLoop fs s rb rh1 ringHash
463+ else skip $ SplitOnSeqKRInit (idx + 1) s rb rh1
464+ Skip s -> skip $ SplitOnSeqKRInit idx s rb rh
465+ Stop -> do
466+ fs <- initial
467+ skip $ SplitOnSeqKRDone idx fs rb (RB.startOf rb)
468+
469+ -- XXX The recursive "go" is more efficient than the state based recursion
470+ -- code commented out below. Perhaps its more efficient because of
471+ -- factoring out "rb" outside the loop.
472+ --
473+ stepOuter gst (SplitOnSeqKRLoop fs0 st0 rb rh0 cksum0) =
474+ go SPEC fs0 st0 rh0 cksum0
475+
476+ where
477+
478+ go !_ !fs !st !rh !cksum = do
479+ res <- step (adaptState gst) st
480+ case res of
481+ Yield x s -> do
482+ old <- liftIO $ peek rh
483+ let cksum1 = deltaCksum cksum old x
484+ r <- fstep fs old
485+ case r of
486+ FL.Partial fs1 -> do
487+ rh1 <- liftIO (RB.unsafeInsert rb rh x)
488+ if cksum1 == patHash
489+ then skip $ SplitOnSeqKRCheck fs1 s rb rh1
490+ else go SPEC fs1 s rh1 cksum1
491+ FL.Done b ->
492+ let next = SplitOnSeqKRInit 0 s rb (RB.startOf rb)
493+ in skip $ SplitOnSeqYield b next
494+ Skip s -> go SPEC fs s rh cksum
495+ Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
496+
497+ -- XXX The following code is 5 times slower compared to the recursive loop
498+ -- based code above. Need to investigate why. One possibility is that the
499+ -- go loop above does not thread around the ring buffer (rb). This code may
500+ -- be causing the state to bloat and getting allocated on each iteration.
501+ -- We can check the cmm/asm code to confirm. If so a good GHC solution to
502+ -- such problem is needed. One way to avoid this could be to use unboxed
503+ -- mutable state?
504+ {-
505+ stepOuter gst (SplitOnSeqKRLoop fs st rb rh cksum) = do
506+ res <- step (adaptState gst) st
507+ case res of
508+ Yield x s -> do
509+ old <- liftIO $ peek rh
510+ let cksum1 = deltaCksum cksum old x
511+ fs1 <- fstep fs old
512+ if (cksum1 == patHash)
513+ then do
514+ r <- done fs1
515+ skip $ SplitOnSeqYield r $ SplitOnSeqKRInit 0 s rb rh
516+ else do
517+ rh1 <- liftIO (RB.unsafeInsert rb rh x)
518+ skip $ SplitOnSeqKRLoop fs1 s rb rh1 cksum1
519+ Skip s -> skip $ SplitOnSeqKRLoop fs s rb rh cksum
520+ Stop -> skip $ SplitOnSeqKRDone patLen fs rb rh
521+ -}
522+
523+ stepOuter _ (SplitOnSeqKRCheck fs st rb rh) = do
524+ if RB.unsafeEqArray rb rh patArr
525+ then do
526+ r <- done fs
527+ let next = SplitOnSeqKRInit 0 st rb (RB.startOf rb)
528+ skip $ SplitOnSeqYield r next
529+ else skip $ SplitOnSeqKRLoop fs st rb rh patHash
530+ stepOuter _ (SplitOnSeqKRDone 0 fs _ _) = do
531+ r <- done fs
532+ skip $ SplitOnSeqYield r SplitOnSeqDone
533+ stepOuter _ (SplitOnSeqKRDone n fs rb rh) = do
534+ old <- liftIO $ peek rh
535+ let rh1 = RB.advance rb rh
536+ r <- fstep fs old
537+ case r of
538+ FL.Partial fs1 -> skip $ SplitOnSeqKRDone (n - 1) fs1 rb rh1
539+ FL.Done b -> do
540+ fs1 <- initial
541+ let next = SplitOnSeqKRDone (n - 1) fs1 rb rh1
542+ skip $ SplitOnSeqYield b next
543+
544+{-# ANN type SplitOnSuffixSeqState Fuse #-}
545+data SplitOnSuffixSeqState rb rh ck w fs s b x =
546+ SplitOnSuffixSeqInit
547+ | SplitOnSuffixSeqYield b (SplitOnSuffixSeqState rb rh ck w fs s b x)
548+ | SplitOnSuffixSeqDone
549+
550+ | SplitOnSuffixSeqEmpty s
551+
552+ | SplitOnSuffixSeqSingleInit s x
553+ | SplitOnSuffixSeqSingle !fs s x
554+
555+ | SplitOnSuffixSeqWordInit s
556+ | SplitOnSuffixSeqWordLoop !w s !fs
557+ | SplitOnSuffixSeqWordDone Int !fs !w
558+
559+ | SplitOnSuffixSeqKRInit Int s rb !rh
560+ | SplitOnSuffixSeqKRInit1 !fs s rb !rh
561+ | SplitOnSuffixSeqKRLoop fs s rb !rh !ck
562+ | SplitOnSuffixSeqKRCheck fs s rb !rh
563+ | SplitOnSuffixSeqKRDone Int !fs rb !rh
564+
565+{-# INLINE_NORMAL splitOnSuffixSeq #-}
566+splitOnSuffixSeq
567+ :: forall m a b. (MonadIO m, Storable a, Enum a, Eq a)
568+ => Bool
569+ -> Array a
570+ -> Fold m a b
571+ -> Stream m a
572+ -> Stream m b
573+splitOnSuffixSeq withSep patArr (Fold fstep initial done) (Stream step state) =
574+ Stream stepOuter SplitOnSuffixSeqInit
575+
576+ where
577+
578+ patLen = A.length patArr
579+ maxIndex = patLen - 1
580+ elemBits = sizeOf (undefined :: a) * 8
581+
582+ -- For word pattern case
583+ wordMask :: Word
584+ wordMask = (1 `shiftL` (elemBits * patLen)) - 1
585+
586+ elemMask :: Word
587+ elemMask = (1 `shiftL` elemBits) - 1
588+
589+ wordPat :: Word
590+ wordPat = wordMask .&. A.foldl' addToWord 0 patArr
591+
592+ addToWord wd a = (wd `shiftL` elemBits) .|. fromIntegral (fromEnum a)
593+
594+ -- For single element pattern case
595+ {-# INLINE processYieldSingle #-}
596+ processYieldSingle pat x s fs =
597+ if pat == x
598+ then do
599+ r <- if withSep then fstep fs x else return $ FL.Partial fs
600+ case r of
601+ FL.Partial fs1 -> do
602+ b <- done fs1
603+ let next = SplitOnSuffixSeqSingleInit s pat
604+ skip $ SplitOnSuffixSeqYield b next
605+ FL.Done b ->
606+ let next = SplitOnSuffixSeqSingleInit s pat
607+ in skip $ SplitOnSuffixSeqYield b next
608+ else do
609+ r <- fstep fs x
610+ case r of
611+ FL.Partial fs1 -> skip $ SplitOnSuffixSeqSingle fs1 s pat
612+ FL.Done b ->
613+ let next = SplitOnSuffixSeqSingleInit s pat
614+ in skip $ SplitOnSuffixSeqYield b next
615+
616+ -- For Rabin-Karp search
617+ k = 2891336453 :: Word32
618+ coeff = k ^ patLen
619+
620+ addCksum cksum a = cksum * k + fromIntegral (fromEnum a)
621+
622+ deltaCksum cksum old new =
623+ addCksum cksum new - coeff * fromIntegral (fromEnum old)
624+
625+ -- XXX shall we use a random starting hash or 1 instead of 0?
626+ patHash = A.foldl' addCksum 0 patArr
627+
628+ skip = return . Skip
629+
630+ {-# INLINE_LATE stepOuter #-}
631+ stepOuter _ SplitOnSuffixSeqInit =
632+ if patLen == 0
633+ then skip $ SplitOnSuffixSeqEmpty state
634+ else if patLen == 1
635+ then do
636+ pat <- liftIO $ A.unsafeIndexIO patArr 0
637+ skip $ SplitOnSuffixSeqSingleInit state pat
638+ else if sizeOf (undefined :: a) * patLen
639+ <= sizeOf (undefined :: Word)
640+ then skip $ SplitOnSuffixSeqWordInit state
641+ else do
642+ (rb, rhead) <- liftIO $ RB.new patLen
643+ skip $ SplitOnSuffixSeqKRInit 0 state rb rhead
644+
645+ stepOuter _ (SplitOnSuffixSeqYield x next) = return $ Yield x next
646+
647+ ---------------------------
648+ -- Empty pattern
649+ ---------------------------
650+
651+ stepOuter gst (SplitOnSuffixSeqEmpty st) = do
652+ res <- step (adaptState gst) st
653+ case res of
654+ Yield x s -> do
655+ acc <- initial
656+ r <- fstep acc x
657+ case r of
658+ FL.Partial fs -> do
659+ b <- done fs
660+ skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
661+ FL.Done b ->
662+ skip $ SplitOnSuffixSeqYield b (SplitOnSuffixSeqEmpty s)
663+ Skip s -> skip (SplitOnSuffixSeqEmpty s)
664+ Stop -> return Stop
665+
666+ -----------------
667+ -- Done
668+ -----------------
669+
670+ stepOuter _ SplitOnSuffixSeqDone = return Stop
671+
672+ -----------------
673+ -- Single Pattern
674+ -----------------
675+
676+ stepOuter gst (SplitOnSuffixSeqSingleInit st pat) = do
677+ res <- step (adaptState gst) st
678+ case res of
679+ Yield x s -> initial >>= processYieldSingle pat x s
680+ Skip s -> skip $ SplitOnSuffixSeqSingleInit s pat
681+ Stop -> return Stop
682+
683+ stepOuter gst (SplitOnSuffixSeqSingle fs st pat) = do
684+ res <- step (adaptState gst) st
685+ case res of
686+ Yield x s -> processYieldSingle pat x s fs
687+ Skip s -> skip $ SplitOnSuffixSeqSingle fs s pat
688+ Stop -> do
689+ r <- done fs
690+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
691+
692+ ---------------------------
693+ -- Short Pattern - Shift Or
694+ ---------------------------
695+
696+ stepOuter _ (SplitOnSuffixSeqWordDone 0 fs _) = do
697+ r <- done fs
698+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
699+ stepOuter _ (SplitOnSuffixSeqWordDone n fs wrd) = do
700+ let old = elemMask .&. (wrd `shiftR` (elemBits * (n - 1)))
701+ r <- fstep fs (toEnum $ fromIntegral old)
702+ case r of
703+ FL.Partial fs1 -> skip $ SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
704+ FL.Done b -> do
705+ fs1 <- initial
706+ let next = SplitOnSuffixSeqWordDone (n - 1) fs1 wrd
707+ skip $ SplitOnSuffixSeqYield b next
708+
709+ stepOuter gst (SplitOnSuffixSeqWordInit st0) = do
710+ res <- step (adaptState gst) st0
711+ case res of
712+ Yield x s -> do
713+ fs <- initial
714+ let wrd = addToWord 0 x
715+ r <- if withSep then fstep fs x else return $ FL.Partial fs
716+ case r of
717+ FL.Partial fs1 -> go SPEC 1 wrd s fs1
718+ FL.Done b -> do
719+ let next = SplitOnSuffixSeqWordInit s
720+ in skip $ SplitOnSuffixSeqYield b next
721+ Skip s -> skip (SplitOnSuffixSeqWordInit s)
722+ Stop -> return Stop
723+
724+ where
725+
726+ {-# INLINE go #-}
727+ go !_ !idx !wrd !st !fs = do
728+ res <- step (adaptState gst) st
729+ case res of
730+ Yield x s -> do
731+ let wrd1 = addToWord wrd x
732+ r <- if withSep then fstep fs x else return $ FL.Partial fs
733+ case r of
734+ FL.Partial fs1 ->
735+ if idx /= maxIndex
736+ then go SPEC (idx + 1) wrd1 s fs1
737+ else if wrd1 .&. wordMask /= wordPat
738+ then skip $ SplitOnSuffixSeqWordLoop wrd1 s fs1
739+ else do
740+ b <- done fs
741+ let next = SplitOnSuffixSeqWordInit s
742+ skip $ SplitOnSuffixSeqYield b next
743+ FL.Done b ->
744+ let next = SplitOnSuffixSeqWordInit s
745+ in skip $ SplitOnSuffixSeqYield b next
746+ Skip s -> go SPEC idx wrd s fs
747+ Stop -> skip $ SplitOnSuffixSeqWordDone idx fs wrd
748+
749+ stepOuter gst (SplitOnSuffixSeqWordLoop wrd0 st0 fs0) =
750+ go SPEC wrd0 st0 fs0
751+
752+ where
753+
754+ {-# INLINE go #-}
755+ go !_ !wrd !st !fs = do
756+ res <- step (adaptState gst) st
757+ case res of
758+ Yield x s -> do
759+ let wrd1 = addToWord wrd x
760+ old = (wordMask .&. wrd)
761+ `shiftR` (elemBits * (patLen - 1))
762+ r <-
763+ if withSep
764+ then fstep fs x
765+ else fstep fs (toEnum $ fromIntegral old)
766+ case r of
767+ FL.Partial fs1 ->
768+ if wrd1 .&. wordMask == wordPat
769+ then do
770+ b <- done fs1
771+ let next = SplitOnSuffixSeqWordInit s
772+ skip $ SplitOnSuffixSeqYield b next
773+ else go SPEC wrd1 s fs1
774+ FL.Done b ->
775+ let next = SplitOnSuffixSeqWordInit s
776+ in skip $ SplitOnSuffixSeqYield b next
777+ Skip s -> go SPEC wrd s fs
778+ Stop ->
779+ if wrd .&. wordMask == wordPat
780+ then return Stop
781+ else if withSep
782+ then do
783+ r <- done fs
784+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
785+ else skip $ SplitOnSuffixSeqWordDone patLen fs wrd
786+
787+ -------------------------------
788+ -- General Pattern - Karp Rabin
789+ -------------------------------
790+
791+ stepOuter gst (SplitOnSuffixSeqKRInit idx0 st0 rb rh0) = do
792+ res <- step (adaptState gst) st0
793+ case res of
794+ Yield x s -> do
795+ rh1 <- liftIO $ RB.unsafeInsert rb rh0 x
796+ fs <- initial
797+ r <- if withSep then fstep fs x else return $ FL.Partial fs
798+ case r of
799+ FL.Partial fs1 ->
800+ skip $ SplitOnSuffixSeqKRInit1 fs1 s rb rh1
801+ FL.Done b ->
802+ let next = SplitOnSuffixSeqKRInit 0 s rb (RB.startOf rb)
803+ in skip $ SplitOnSuffixSeqYield b next
804+ Skip s -> skip $ SplitOnSuffixSeqKRInit idx0 s rb rh0
805+ Stop -> return Stop
806+
807+ stepOuter gst (SplitOnSuffixSeqKRInit1 fs0 st0 rb rh0) = do
808+ go SPEC 1 rh0 st0 fs0
809+
810+ where
811+
812+ go !_ !idx !rh st !fs = do
813+ res <- step (adaptState gst) st
814+ case res of
815+ Yield x s -> do
816+ rh1 <- liftIO (RB.unsafeInsert rb rh x)
817+ r <- if withSep then fstep fs x else return $ FL.Partial fs
818+ case r of
819+ FL.Partial fs1 ->
820+ if idx /= maxIndex
821+ then go SPEC (idx + 1) rh1 s fs1
822+ else skip $
823+ let fold = RB.unsafeFoldRing (RB.ringBound rb)
824+ !ringHash = fold addCksum 0 rb
825+ in if ringHash == patHash
826+ then SplitOnSuffixSeqKRCheck fs1 s rb rh1
827+ else SplitOnSuffixSeqKRLoop
828+ fs1 s rb rh1 ringHash
829+ FL.Done b ->
830+ let next = SplitOnSuffixSeqKRInit
831+ 0 st rb (RB.startOf rb)
832+ in skip $ SplitOnSuffixSeqYield b next
833+ Skip s -> go SPEC idx rh s fs
834+ Stop -> do
835+ -- do not issue a blank segment when we end at pattern
836+ if (idx == maxIndex) && RB.unsafeEqArray rb rh patArr
837+ then return Stop
838+ else if withSep
839+ then do
840+ r <- done fs
841+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
842+ else skip $ SplitOnSuffixSeqKRDone idx fs rb (RB.startOf rb)
843+
844+ stepOuter gst (SplitOnSuffixSeqKRLoop fs0 st0 rb rh0 cksum0) =
845+ go SPEC fs0 st0 rh0 cksum0
846+
847+ where
848+
849+ go !_ !fs !st !rh !cksum = do
850+ res <- step (adaptState gst) st
851+ case res of
852+ Yield x s -> do
853+ old <- liftIO $ peek rh
854+ rh1 <- liftIO (RB.unsafeInsert rb rh x)
855+ let cksum1 = deltaCksum cksum old x
856+ r <- if withSep then fstep fs x else fstep fs old
857+ case r of
858+ FL.Partial fs1 ->
859+ if (cksum1 /= patHash)
860+ then go SPEC fs1 s rh1 cksum1
861+ else skip $ SplitOnSuffixSeqKRCheck fs1 s rb rh1
862+ FL.Done b ->
863+ let next = SplitOnSuffixSeqKRInit
864+ 0 st rb (RB.startOf rb)
865+ in skip $ SplitOnSuffixSeqYield b next
866+ Skip s -> go SPEC fs s rh cksum
867+ Stop ->
868+ if RB.unsafeEqArray rb rh patArr
869+ then return Stop
870+ else if withSep
871+ then do
872+ r <- done fs
873+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
874+ else skip $ SplitOnSuffixSeqKRDone patLen fs rb rh
875+
876+ stepOuter _ (SplitOnSuffixSeqKRCheck fs st rb rh) = do
877+ if RB.unsafeEqArray rb rh patArr
878+ then do
879+ r <- done fs
880+ let next = SplitOnSuffixSeqKRInit 0 st rb (RB.startOf rb)
881+ skip $ SplitOnSuffixSeqYield r next
882+ else skip $ SplitOnSuffixSeqKRLoop fs st rb rh patHash
883+
884+ stepOuter _ (SplitOnSuffixSeqKRDone 0 fs _ _) = do
885+ r <- done fs
886+ skip $ SplitOnSuffixSeqYield r SplitOnSuffixSeqDone
887+ stepOuter _ (SplitOnSuffixSeqKRDone n fs rb rh) = do
888+ old <- liftIO $ peek rh
889+ let rh1 = RB.advance rb rh
890+ r <- fstep fs old
891+ case r of
892+ FL.Partial fs1 -> skip $ SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
893+ FL.Done b -> do
894+ fs1 <- initial
895+ let next = SplitOnSuffixSeqKRDone (n - 1) fs1 rb rh1
896+ skip $ SplitOnSuffixSeqYield b next
897+
898+{-# ANN type SplitState Fuse #-}
899+data SplitState s arr
900+ = SplitInitial s
901+ | SplitBuffering s arr
902+ | SplitSplitting s arr
903+ | SplitYielding arr (SplitState s arr)
904+ | SplitFinishing
905+
906+-- XXX An alternative approach would be to use a partial fold (Fold m a b) to
907+-- split using a splitBy like combinator. The Fold would consume upto the
908+-- separator and return any leftover which can then be fed to the next fold.
909+--
910+-- We can revisit this once we have partial folds/parsers.
911+--
912+-- | Performs infix separator style splitting.
913+{-# INLINE_NORMAL splitInnerBy #-}
914+splitInnerBy
915+ :: Monad m
916+ => (f a -> m (f a, Maybe (f a))) -- splitter
917+ -> (f a -> f a -> m (f a)) -- joiner
918+ -> Stream m (f a)
919+ -> Stream m (f a)
920+splitInnerBy splitter joiner (Stream step1 state1) =
921+ (Stream step (SplitInitial state1))
922+
923+ where
924+
925+ {-# INLINE_LATE step #-}
926+ step gst (SplitInitial st) = do
927+ r <- step1 gst st
928+ case r of
929+ Yield x s -> do
930+ (x1, mx2) <- splitter x
931+ return $ case mx2 of
932+ Nothing -> Skip (SplitBuffering s x1)
933+ Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
934+ Skip s -> return $ Skip (SplitInitial s)
935+ Stop -> return $ Stop
936+
937+ step gst (SplitBuffering st buf) = do
938+ r <- step1 gst st
939+ case r of
940+ Yield x s -> do
941+ (x1, mx2) <- splitter x
942+ buf' <- joiner buf x1
943+ return $ case mx2 of
944+ Nothing -> Skip (SplitBuffering s buf')
945+ Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
946+ Skip s -> return $ Skip (SplitBuffering s buf)
947+ Stop -> return $ Skip (SplitYielding buf SplitFinishing)
948+
949+ step _ (SplitSplitting st buf) = do
950+ (x1, mx2) <- splitter buf
951+ return $ case mx2 of
952+ Nothing -> Skip $ SplitBuffering st x1
953+ Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
954+
955+ step _ (SplitYielding x next) = return $ Yield x next
956+ step _ SplitFinishing = return $ Stop
957+
958+-- | Performs infix separator style splitting.
959+{-# INLINE_NORMAL splitInnerBySuffix #-}
960+splitInnerBySuffix
961+ :: (Monad m, Eq (f a), Monoid (f a))
962+ => (f a -> m (f a, Maybe (f a))) -- splitter
963+ -> (f a -> f a -> m (f a)) -- joiner
964+ -> Stream m (f a)
965+ -> Stream m (f a)
966+splitInnerBySuffix splitter joiner (Stream step1 state1) =
967+ (Stream step (SplitInitial state1))
968+
969+ where
970+
971+ {-# INLINE_LATE step #-}
972+ step gst (SplitInitial st) = do
973+ r <- step1 gst st
974+ case r of
975+ Yield x s -> do
976+ (x1, mx2) <- splitter x
977+ return $ case mx2 of
978+ Nothing -> Skip (SplitBuffering s x1)
979+ Just x2 -> Skip (SplitYielding x1 (SplitSplitting s x2))
980+ Skip s -> return $ Skip (SplitInitial s)
981+ Stop -> return $ Stop
982+
983+ step gst (SplitBuffering st buf) = do
984+ r <- step1 gst st
985+ case r of
986+ Yield x s -> do
987+ (x1, mx2) <- splitter x
988+ buf' <- joiner buf x1
989+ return $ case mx2 of
990+ Nothing -> Skip (SplitBuffering s buf')
991+ Just x2 -> Skip (SplitYielding buf' (SplitSplitting s x2))
992+ Skip s -> return $ Skip (SplitBuffering s buf)
993+ Stop -> return $
994+ if buf == mempty
995+ then Stop
996+ else Skip (SplitYielding buf SplitFinishing)
997+
998+ step _ (SplitSplitting st buf) = do
999+ (x1, mx2) <- splitter buf
1000+ return $ case mx2 of
1001+ Nothing -> Skip $ SplitBuffering st x1
1002+ Just x2 -> Skip $ SplitYielding x1 (SplitSplitting st x2)
1003+
1004+ step _ (SplitYielding x next) = return $ Yield x next
1005+ step _ SplitFinishing = return Stop
streamly.cabal+1
@@ -453,6 +453,7 @@ library
453 , Streamly.Internal.Data.Stream.StreamD.Type
453 , Streamly.Internal.Data.Stream.StreamD.Type
454 , Streamly.Internal.Data.Stream.StreamD
454 , Streamly.Internal.Data.Stream.StreamD
455 , Streamly.Internal.Data.Stream.StreamD.Generate
455 , Streamly.Internal.Data.Stream.StreamD.Generate
456+ , Streamly.Internal.Data.Stream.StreamD.SplitGroup
456 , Streamly.Internal.Data.Stream.StreamDK.Type
457 , Streamly.Internal.Data.Stream.StreamDK.Type
457 , Streamly.Internal.Data.Stream.StreamDK
458 , Streamly.Internal.Data.Stream.StreamDK
458 , Streamly.Internal.Data.Stream.Enumeration
459 , Streamly.Internal.Data.Stream.Enumeration