@@ -312,11 +312,9 @@ import Control.Monad.Trans.Reader (ReaderT)
312312import Control.Monad.Trans.State.Strict (StateT)
313313import Control.Monad.Trans.Class (MonadTrans(lift))
314314import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_, control)
315−import Data.Bits (shiftR, shiftL, (.|.), (.&.))
316315import Data.Functor.Identity (Identity(..))
317316import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef)
318317import Data.Maybe (fromJust, isJust)
319−import Data.Word (Word32)
320318import Foreign.Storable (Storable(..))
321319import GHC.Exts (SpecConstrAnnotation(..))
322320import GHC.Types (SPEC(..))
@@ -324,7 +322,6 @@ import Fusion.Plugin.Types (Fuse(..))
324322import Streamly.Internal.Data.Time.Units
325323 (TimeUnit64, toRelTime64, diffAbsTime64)
326324import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_)
327−import Streamly.Internal.Data.Array.Storable.Foreign.Types (Array(..))
328325import Streamly.Internal.Data.Fold.Types (Fold(..))
329326import Streamly.Internal.Data.Parser (ParseError(..))
330327import Streamly.Internal.Data.Pipe.Types (Pipe(..), PipeState(..))
@@ -336,7 +333,6 @@ import qualified Streamly.Internal.Data.IORef.Prim as Prim
336333import qualified Streamly.Internal.Data.Pipe.Types as Pipe
337334import qualified Streamly.Internal.Data.Array.Storable.Foreign.Types as A
338335import qualified Streamly.Internal.Data.Fold as FL
339−import qualified Streamly.Memory.Ring as RB
340336import qualified Streamly.Internal.Data.Stream.StreamK as K
341337import qualified Streamly.Internal.Data.Parser as PR
342338import qualified Streamly.Internal.Data.Parser.ParserD as PRD
@@ -353,6 +349,7 @@ import Prelude hiding
353349 , reverse, iterate, splitAt)
354350import Streamly.Internal.Data.Stream.StreamD.Type
355351import Streamly.Internal.Data.Stream.StreamD.Generate
352+import Streamly.Internal.Data.Stream.StreamD.SplitGroup
356353import Streamly.Internal.Data.SVar
357354
358355------------------------------------------------------------------------------
@@ -1152,964 +1149,6 @@ reverse' m =
11521149 $ toStreamK
11531150 $ A.fromStreamDArraysOf A.defaultChunkSize m
11541151
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−
21131152------------------------------------------------------------------------------
21141153-- Substreams
21151154------------------------------------------------------------------------------