diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +# 0.4.7.0 + +- Added "sections" splitter. +- Deprecated Control.Foldl.Transduce.Textual + # 0.4.6.0 - Deprecated Control.Foldl.Transduce.ByteString.IO diff --git a/foldl-transduce.cabal b/foldl-transduce.cabal --- a/foldl-transduce.cabal +++ b/foldl-transduce.cabal @@ -1,5 +1,5 @@ Name: foldl-transduce -Version: 0.4.6.0 +Version: 0.4.7.0 Cabal-Version: >=1.8.0.2 Build-Type: Simple License: BSD3 diff --git a/src/Control/Foldl/Transduce/Text.hs b/src/Control/Foldl/Transduce/Text.hs --- a/src/Control/Foldl/Transduce/Text.hs +++ b/src/Control/Foldl/Transduce/Text.hs @@ -21,26 +21,32 @@ , words , lines , paragraphs - -- * Re-exports - -- $reexports - , module Control.Foldl.Transduce.Textual + , sections + -- * Textual + -- $textual + , textualSplit + , textualBreak ) where import Prelude hiding (lines,words) import Data.Char -import Data.Monoid (mempty) +import Data.Bool +import Data.Maybe +import Data.List (unfoldr) +import Data.Monoid (mempty,(<>)) import Data.Foldable (foldMap,foldl') import qualified Data.ByteString as B import qualified Data.Text import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Encoding.Error as T +import qualified Data.Monoid.Textual as MT +import qualified Data.Monoid.Null as MN import Control.Applicative import Control.Monad.Trans.Except import Control.Monad.IO.Class import Control.Exception.Base import qualified Control.Foldl.Transduce as L -import Control.Foldl.Transduce.Textual import Control.Foldl.Transduce.Internal (Pair(..)) import qualified Data.List import Data.List.Split @@ -337,7 +343,7 @@ (SkippingAfterStreamStart, False) -> (,) SkippingAfterNewline - (prepend ["\n",T.stripStart i] outputs) + (continue ["\n",T.stripStart i] outputs) (SkippingAfterNewline, True) -> (,) SkippingAfterBlankLine @@ -345,7 +351,7 @@ (SkippingAfterNewline, False) -> (,) SkippingAfterNewline - (prepend ["\n",T.stripStart i] outputs) + (continue ["\n",T.stripStart i] outputs) (SkippingAfterBlankLine, True) -> (,) SkippingAfterBlankLine @@ -353,11 +359,11 @@ (SkippingAfterBlankLine, False) -> (,) SkippingAfterNewline - (prepend ["\n",T.stripStart i] (NonEmpty.cons [] outputs)) + (continue ["\n",T.stripStart i] (NonEmpty.cons [] outputs)) (ContinuingNonemptyLine, _) -> (,) SkippingAfterNewline - (prepend ["\n",i] outputs) + (continue ["\n",i] outputs) advanceLast :: (ParagraphsState, NonEmpty [T.Text]) -> T.Text @@ -371,7 +377,7 @@ (SkippingAfterStreamStart, False) -> (,) ContinuingNonemptyLine - (prepend [T.stripStart i] outputs) + (continue [T.stripStart i] outputs) (SkippingAfterNewline, True) -> (,) SkippingAfterNewline @@ -379,7 +385,7 @@ (SkippingAfterNewline, False) -> (,) ContinuingNonemptyLine - (prepend [T.stripStart i] outputs) + (continue [T.stripStart i] outputs) (SkippingAfterBlankLine, True) -> (,) SkippingAfterBlankLine @@ -387,16 +393,145 @@ (SkippingAfterBlankLine, False) -> (,) ContinuingNonemptyLine - (prepend [T.stripStart i] (NonEmpty.cons [] outputs)) + (continue [T.stripStart i] (NonEmpty.cons [] outputs)) (ContinuingNonemptyLine, _) -> (,) ContinuingNonemptyLine - (prepend [i] outputs) - prepend :: [a] -> NonEmpty [a] -> NonEmpty [a] - prepend as (as':| rest) = (as ++ as') :| rest + (continue [i] outputs) +{-| + + Given a (possibly infinite) list of section headings, split the stream into + sections and remove the headings. + +>>> map mconcat (L.fold (folds (sections (map T.pack ["#1\n","#2\n"])) L.list L.list) (map T.pack [" #1\naa\n#","2\nbb"])) +[" ","aa\n","bb"] + +>>> map mconcat (L.fold (folds (sections (map T.pack ["1234"])) L.list L.list) (map T.pack [" 1","2","x","1","2","3","4","5"])) +[" 12x","5"] + + Used with 'L.transduce', it simply removes all headings. +-} +sections :: [T.Text] -> L.Transducer T.Text T.Text () +sections seps = L.Transducer step (initialstate seps) done + where + step tstate txt = + let (emitted,fmap snd -> states) = Data.List.unzip (unfoldWithState splitTextStep (txt,tstate)) + finalState = NonEmpty.last (tstate :| states) + continuing :| following = NonEmpty.reverse (fmap Data.List.reverse (foldl' advance ([]:|[]) emitted)) + in (finalState, continuing, following) + advance :: NonEmpty [x] -> ([x],Bool) -> NonEmpty [x] + advance l (e,b) = bool id (separate []) b (continue e l) + done Done = + ((),[],[]) + done (Pending acc _ _) = + ((),[acc],[]) + initialstate [] = Done + initialstate (x:xs) = Pending T.empty x xs + + +continue :: [a] -> NonEmpty [a] -> NonEmpty [a] +continue as (as':| rest) = (as ++ as') :| rest + +separate :: [x] -> NonEmpty [x] -> NonEmpty [x] +separate = NonEmpty.cons + +data SectionsState = + Done + | Pending T.Text T.Text [T.Text] -- first is the accumulator + deriving (Show) + +{-| + +>>> splitTextStep (T.pack "x",Done) +Just ((["x"],False),("",Done)) + +>>> splitTextStep (T.pack "aabbcc",Pending T.empty (T.pack "bb") []) +Just ((["aa"],True),("cc",Done)) + +>>> splitTextStep (T.pack "cc",Pending (T.pack "bb") (T.pack "bbcc") [T.pack "nextsep"]) +Just (([""],True),("",Pending "" "nextsep" [])) + +>>> splitTextStep (T.pack "xx",Pending (T.pack "bb") (T.pack "bbcc") []) +Just ((["bbxx"],False),("",Pending "" "bbcc" [])) + +>>> splitTextStep (T.pack "xbb",Pending (T.pack "bbc") (T.pack "bbcccc") []) +Just ((["bbcx"],False),("",Pending "bb" "bbcccc" [])) + +-} +splitTextStep + :: (T.Text, SectionsState) + -> Maybe (([T.Text],Bool), (T.Text, SectionsState)) +splitTextStep (txt, _) | T.null txt = Nothing +splitTextStep (txt, Done) = Just (([txt],False),(T.empty,Done)) +splitTextStep (txt, Pending acc sep nextseps) = Just $ + let (before,after) = T.breakOn sep (acc <> txt) + in + if T.null after + then -- not present + let (m0,m) = maxintersect before sep + in + (([m0],False),(T.empty, Pending m sep nextseps)) + else -- present + let unprefixed = T.drop (T.length sep) after + nextstate = case nextseps of + [] -> Done + z:zs -> Pending T.empty z zs + in + (([before],True),(unprefixed,nextstate)) + +maxintersect :: T.Text -> T.Text -> (T.Text,T.Text) +maxintersect txt sep = + let prefixes = (tail . reverse . tail . T.inits) sep + partialmatches = filter (flip T.isSuffixOf txt) prefixes + m = maybe T.empty id (listToMaybe partialmatches) + in + (T.take (T.length txt - T.length m) txt,m) + +unfoldWithState :: (b -> Maybe (a, b)) -> b -> [(a, b)] +unfoldWithState f = unfoldr (fmap (\t@(_, b) -> (t, b)) . f) + ------------------------------------------------------------------------------ -{- $reexports +{- $textual + Transducers that work on 'Text' and other text-like types. + -} + +{-| + +>>> L.fold (folds (textualSplit (=='.')) L.list L.list) [".","bb.bb","c.c."] +[[""],["","bb"],["bb","c"],["c"],[""]] + +-} + +textualSplit :: MT.TextualMonoid m => (Char -> Bool) -> L.Transducer m m () +textualSplit predicate = L.Transducer step () done + where + step _ txt = case MT.split predicate txt of + x:xs -> ((),[x],map (:[]) xs) + _ -> error "never happens" + done _ = mempty + + +data SplitWhenWhenState = + SplitWhenConditionEncountered + | SplitWhenConditionPending + +{-| + +>>> L.fold (bisect (textualBreak (=='.')) (reify id) ignore L.list) ["aa","bb.bb","cc"] +["aa","bb"] +-} +textualBreak :: MT.TextualMonoid m => (Char -> Bool) -> L.Transducer m m () +textualBreak predicate = + L.Transducer step SplitWhenConditionPending done + where + step SplitWhenConditionPending (MT.break (const False) predicate -> (i0,i1)) = + if MN.null i1 + then (SplitWhenConditionPending,[i0],[]) + else (SplitWhenConditionEncountered,[i0],[[i1]]) + step SplitWhenConditionEncountered i = + (SplitWhenConditionEncountered,[i],[]) + done = mempty diff --git a/src/Control/Foldl/Transduce/Textual.hs b/src/Control/Foldl/Transduce/Textual.hs --- a/src/Control/Foldl/Transduce/Textual.hs +++ b/src/Control/Foldl/Transduce/Textual.hs @@ -3,7 +3,7 @@ -- | -- -- This module has transducers that work on 'Text' and other text-like types. -module Control.Foldl.Transduce.Textual ( +module Control.Foldl.Transduce.Textual {-# DEPRECATED "Use Control.Foldl.Transduce.Text instead." #-} ( -- * Splitters textualSplit , textualBreak diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -18,7 +18,6 @@ import qualified Control.Foldl as L import Control.Foldl.Transduce import Control.Foldl.Transduce.Text -import Control.Foldl.Transduce.Textual {- $quickcheck @@ -132,6 +131,11 @@ paragraphsUnderTest txt = map mconcat (L.fold (folds paragraphs L.list L.list) txt) +sectionsUnderTest + :: [T.Text] -> [T.Text] -> [T.Text] +sectionsUnderTest stns txt = + map mconcat (L.fold (folds (sections stns) L.list L.list) txt) + paragraph01 :: T.Text paragraph01 = T.pack @@ -220,6 +224,21 @@ == ignoreLastNewline (paragraphsBaseline (mconcat chunks))) ] + ], + testGroup "sections" + [ + testCaseEq "no separators at all" + (map T.pack ["aaabbcc"]) + (sectionsUnderTest (map T.pack []) (map T.pack ["a","aa","bbc","c"])), + testCaseEq "incomplete separator" + (map T.pack ["123#_","aa","bb#"]) + (sectionsUnderTest (map T.pack ["1234","#"]) (map T.pack ["1","23","#_1234aa#b","b#"])), + testCaseEq "small chunks" + (map T.pack ["0","01","aa","a#bb","c"]) + (sectionsUnderTest (map T.pack ["_","_","##","##","##"]) (map T.pack ["0","_","0","1_","a","a","#","#a","#","b","b#","#","c"])), + testCaseEq "big chunk with multiple seps" + (map T.pack ["1x","aa","bb","cc1x","dd"]) + (sectionsUnderTest (map T.pack (cycle ["12"])) (map T.pack ["1","x12aa12bb12cc1","x1","2dd"])) ], testGroup "quiesceWith" [