foldl-transduce (empty) → 0.0.1
raw patch · 9 files changed
+773/−0 lines, 9 filesdep +basedep +bytestringdep +comonadsetup-changed
Dependencies added: base, bytestring, comonad, containers, criterion, doctest, foldl, foldl-transduce, profunctors, semigroupoids, tasty, tasty-hunit, text, transformers
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- benchmarks/benchmarks.hs +8/−0
- foldl-transduce.cabal +69/−0
- src/Control/Foldl/Transduce.hs +376/−0
- src/Control/Foldl/Transduce/Internal.hs +7/−0
- src/Control/Foldl/Transduce/Text.hs +214/−0
- tests/doctests.hs +10/−0
- tests/tests.hs +59/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Daniel Díaz Carrete+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of foldl-transduce nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmarks/benchmarks.hs view
@@ -0,0 +1,8 @@+module Main where++import qualified Control.Foldl as L+import qualified Control.Foldl.Transduce++-- TBD+main :: IO ()+main = return ()
+ foldl-transduce.cabal view
@@ -0,0 +1,69 @@+Name: foldl-transduce+Version: 0.0.1+Cabal-Version: >=1.8.0.2+Build-Type: Simple+License: BSD3+License-File: LICENSE+Copyright: 2015 Daniel Diaz+Author: Daniel Diaz+Maintainer: diaz_carrete@yahoo.com+Bug-Reports: https://github.com/danidiaz/foldl-transduce/issues+Synopsis: Transducers for folds from foldl.+Description: Stateful transducers and streaming-preserving grouping operations for the folds from the foldl package.+Category: Control+Source-Repository head+ Type: git+ Location: git@github.com:danidiaz/foldl-transduce.git++Library+ HS-Source-Dirs: src+ Build-Depends:+ base >= 4 && < 5 ,+ bytestring >= 0.9.2.1 && < 0.11,+ text >= 0.11.2.0 && < 1.3 ,+ transformers >= 0.2.0.0 && < 0.5 ,+ containers < 0.6 ,+ profunctors < 5.2 ,+ semigroupoids >= 5.0 ,+ foldl >= 1.1 && < 2 ,+ comonad == 4.*+ Exposed-Modules:+ Control.Foldl.Transduce,+ Control.Foldl.Transduce.Text,+ Control.Foldl.Transduce.Internal+ GHC-Options: -O2 -Wall++test-suite doctests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ main-is: doctests.hs++ build-depends:+ base >= 4.4 && < 5+ , doctest >= 0.10.1++test-suite tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -threaded+ hs-source-dirs: tests+ main-is: tests.hs+ build-depends:+ base >= 4.4 && < 5 ,+ text ,+ tasty >= 0.10.1.1 ,+ tasty-hunit >= 0.9.2,+ foldl ,+ foldl-transduce++benchmark benchmarks+ Type: exitcode-stdio-1.0+ HS-Source-Dirs: benchmarks+ Main-Is: benchmarks.hs+ GHC-Options: -O2 -Wall -rtsopts ++ Build-Depends:+ base >= 4.4 && < 5 ,+ criterion >= 1.1.0.0 && < 1.2,+ foldl ,+ foldl-transduce
+ src/Control/Foldl/Transduce.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE ExistentialQuantification, RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP #-}++-- |+--+-- This module builds on module "Control.Foldl", adding stateful transducers+-- and grouping operations.++module Control.Foldl.Transduce (+ -- * Transducer types+ Transduction + , Transducer(..)+ , TransductionM+ , TransducerM(..)+ -- * Applying transducers+ , transduce+ , transduce'+ , transduceM+ , transduceM'+ -- * Transducers+ , surround+ , surroundIO+ -- * Transducer utilities+ , generalize'+ , simplify'+ , foldify+ , foldifyM+ , chokepoint + , chokepointM+ , hoistTransducer+ , hoistFold+ -- * Splitter types+ , Splitter(..)+ -- * Working with groups+ , groups+ , groupsM+ , folds+ , foldsM+ -- * Splitters+ , chunksOf+ -- * Re-exports+ -- $reexports+ , module Data.Functor.Extend+ , module Control.Foldl+ ) where++import Data.Bifunctor+import Data.Functor.Identity+import Data.Functor.Extend+import Data.Foldable (foldlM,foldl',toList)+import Control.Monad+import Control.Monad.IO.Class+import Control.Comonad+import Control.Foldl (Fold(..),FoldM(..))+import qualified Control.Foldl as L+import Control.Foldl.Transduce.Internal(Pair(..))++{- $setup++>>> import qualified Control.Foldl as L+>>> import Control.Foldl.Transduce++-}++------------------------------------------------------------------------------++#if !(MIN_VERSION_foldl(1,1,2))+instance Comonad (Fold a) where+ extract (Fold _ begin done) = done begin+ {-# INLINABLE extract #-}++ duplicate (Fold step begin done) = Fold step begin (\x -> Fold step x done)+ {-# INLINABLE duplicate #-}+#endif++instance Extend (Fold a) where+ duplicated f = duplicate f+ {-# INLINABLE duplicated #-}++instance Monad m => Extend (FoldM m a) where+ duplicated (FoldM step begin done) = + FoldM step begin (\x -> pure $! FoldM step (pure x) done)+ {-# INLINABLE duplicated #-}++------------------------------------------------------------------------------++{-| A (possibly stateful) transformation on the inputs of a 'Fold'.++ Functions constructed with combinators like 'L.premap' of "Control.Foldl"+ also typecheck as 'Transduction'.+-}+type Transduction a b = forall x. Fold b x -> Fold a x+++{-| Representation of a stateful 'Transduction' with step function, an initial+ accumulator, and a extraction function that returns a summary value of type+ @r@. Both the step function and the extraction function may send output+ downstream.++-}+data Transducer i o r+ = forall x. Transducer (x -> i -> (x,[o])) x (x -> (r,[o]))++instance Functor (Transducer i o) where+ fmap f (Transducer step begin done) = Transducer step begin (first f . done)++instance Bifunctor (Transducer i) where+ first f (Transducer step begin done) =+ Transducer (fmap (fmap (fmap f)) . step) begin (fmap (fmap f) . done)+ second f w = fmap f w++type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x++{-| Like 'Transducer', but monadic.++-}+data TransducerM m i o r+ = forall x. TransducerM (x -> i -> m (x,[o])) (m x) (x -> m (r,[o]))++instance Monad m => Functor (TransducerM m i o) where+ fmap f (TransducerM step begin done) = TransducerM step begin done'+ where+ done' x = do+ (r,os) <- done x+ let r' = f r+ return $! (r' `seq` (r', os))++instance Monad m => Bifunctor (TransducerM m i) where+ first f (TransducerM step begin done) =+ TransducerM (fmap (fmap (fmap (fmap f))) . step) begin (fmap (fmap (fmap f)) . done)+ second f w = fmap f w++{-| Apply a 'Transducer' to a 'Fold', discarding the return value of the+ 'Transducer'. ++>>> L.fold (transduce (Transducer (\_ i -> ((),[i])) () (\_ -> ('r',[]))) L.list) [1..7]+[1,2,3,4,5,6,7]+-}+transduce :: Transducer i o r -> Transduction i o +transduce = transduce' (flip const) ++{-| Generalized version of 'transduce' than doesn't ignore the return value of+ the 'Transducer'.++>>> L.fold (transduce' (,) (Transducer (\_ i -> ((),[i])) () (\_ -> ('r',[]))) L.list) [1..7]+('r',[1,2,3,4,5,6,7])+-}+transduce' :: (x -> y -> z) -> Transducer i o x -> Fold o y -> Fold i z+transduce' f (Transducer wstep wstate wdone) (Fold fstep fstate fdone) =+ Fold step (Pair wstate fstate) done + where+ step (Pair ws fs) i = + let (ws',os) = wstep ws i + in+ Pair ws' (foldl' fstep fs os) + done (Pair ws fs) = + let (wr,os) = wdone ws+ in + f wr (fdone (foldl' fstep fs os))+++transduceM :: Monad m => TransducerM m i o r -> TransductionM m i o +transduceM = transduceM' (flip const)++transduceM' :: Monad m => (x -> y -> z) -> TransducerM m i o x -> FoldM m o y -> FoldM m i z+transduceM' f (TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) =+ FoldM step (liftM2 Pair wstate fstate) done + where+ step (Pair ws fs) i = do+ (ws',os) <- wstep ws i+ fs' <- foldlM fstep fs os+ return $! Pair ws' fs'+ done (Pair ws fs) = do+ (wr,os) <- wdone ws+ fr <- fdone =<< foldlM fstep fs os+ return $! f wr fr++------------------------------------------------------------------------------++data SurroundState = PrefixAdded | PrefixPending++{-| Adds a prefix and a suffix to the stream arriving into a 'Fold'. ++>>> L.fold (transduce (surround "prefix" "suffix") L.list) "middle"+"prefixmiddlesuffix"+-}+surround :: (Foldable p, Foldable s) => p a -> s a -> Transducer a a ()+surround (toList -> ps) (toList -> ss) = + Transducer step PrefixPending done + where+ step PrefixPending a = + (PrefixAdded, ps ++ [a])+ step PrefixAdded a = + (PrefixAdded, [a])+ done PrefixPending = ((), ps ++ ss)+ done PrefixAdded = ((), ss)++{-| Like 'surround', but the prefix and suffix are obtained using a 'IO'+ action.++>>> L.foldM (transduceM (surroundIO (return "prefix") (return "suffix")) (L.generalize L.list)) "middle"+"prefixmiddlesuffix"+-}+surroundIO :: (Foldable p, Foldable s, MonadIO m) + => m (p a) + -> m (s a) + -> TransducerM m a a ()+surroundIO prefixa suffixa = + TransducerM step (return PrefixPending) done + where+ step PrefixPending a = do+ ps <- fmap toList prefixa+ return (PrefixAdded, ps ++ [a])+ step PrefixAdded a = + return (PrefixAdded, [a])+ done PrefixPending = do+ ps <- fmap toList prefixa+ ss <- fmap toList suffixa+ return ((), toList ps ++ toList ss)+ done PrefixAdded = do+ ss <- fmap toList suffixa+ return ((), toList ss)++------------------------------------------------------------------------------++{-| Generalize a 'Transducer' to a 'TransducerM'. ++-}+generalize' :: Monad m => Transducer i o r -> TransducerM m i o r+generalize' (Transducer step begin done) = TransducerM step' begin' done'+ where+ step' x a = return (step x a)+ begin' = return begin+ done' x = return (done x)++{-| Simplify a pure 'TransducerM' to a 'Transducer'. ++-}+simplify' :: TransducerM Identity i o r -> Transducer i o r+simplify' (TransducerM step begin done) = Transducer step' begin' done' where+ step' x a = runIdentity (step x a)+ begin' = runIdentity begin+ done' x = runIdentity (done x)++{-| Transforms a 'Transducer' into a 'Fold' by forgetting about the data sent+ downstream. ++-}+foldify :: Transducer i o r -> Fold i r+foldify (Transducer step begin done) =+ Fold (\x i -> fst (step x i)) begin (\x -> fst (done x))++foldifyM :: Functor m => TransducerM m i o r -> FoldM m i r+foldifyM (TransducerM step begin done) =+ FoldM (\x i -> fmap fst (step x i)) begin (\x -> fmap fst (done x))++{-| Transforms a 'Fold' into a 'Transducer' that sends the return value of the+ 'Fold' downstream when upstream closes. ++-}+chokepoint :: Fold i b -> Transducer i b ()+chokepoint (Fold fstep fstate fdone) =+ (Transducer wstep fstate wdone)+ where+ wstep = \fstate' i -> (fstep fstate' i,[])+ wdone = \fstate' -> ((),[fdone fstate'])++chokepointM :: Applicative m => FoldM m i b -> TransducerM m i b ()+chokepointM (FoldM fstep fstate fdone) = + (TransducerM wstep fstate wdone)+ where+ wstep = \fstate' i -> fmap (\s -> (s,[])) (fstep fstate' i)+ wdone = \fstate' -> fmap (\r -> ((),[r])) (fdone fstate')+++{-| Changes the base monad used by a 'TransducerM'. ++-}+hoistTransducer :: Monad m => (forall a. m a -> n a) -> TransducerM m i o r -> TransducerM n i o r +hoistTransducer g (TransducerM step begin done) = TransducerM (\s i -> g (step s i)) (g begin) (g . done)++{-| Changes the base monad used by a 'FoldM'. ++-}+hoistFold :: Monad m => (forall a. m a -> n a) -> FoldM m i r -> FoldM n i r +hoistFold g (FoldM step begin done) = FoldM (\s i -> g (step s i)) (g begin) (g . done)++------------------------------------------------------------------------------++{-| A procedure for splitting a stream into delimited segments. It is+ composed of a step function, an initial state, and a /done/ function that+ may flush some accumulated output downstream.++ The step function returns a triplet of:++ * The new internal state.+ * Output that continues the last segment detected in the previous step.+ * A list of lists containing new segments detected in the current step. If+ the list is empty, that means no splitting has taken place in the current+ step.+-}+data Splitter i+ = forall x. Splitter (x -> i -> (x,[i],[[i]])) x (x -> [i])++{-| Applies a 'Transduction' to all groups detected by a 'Splitter', returning+ a 'Transduction' that works over the undivided stream of inputs. ++-}+groups :: Splitter i -> Transduction i b -> Transduction i b +groups (Splitter sstep sbegin sdone) t f =+ Fold step (Pair sbegin (t (duplicated f))) done + where+ step (Pair ss fs) i = + let + (ss', oldSplit, newSplits) = sstep ss i+ fs' = foldl' (step' . reset) (step' fs oldSplit) newSplits+ in+ Pair ss' fs'+ step' = L.fold . duplicated+ reset (Fold _ fstate fdone) = + t (duplicated (fdone fstate)) + done (Pair ss (Fold fstep fstate fdone)) = + extract (fdone (foldl' fstep fstate (sdone ss)))++groupsM :: Monad m => Splitter i -> TransductionM m i b -> TransductionM m i b+groupsM (Splitter sstep sbegin sdone) t f = + FoldM step (return (Pair sbegin (t (duplicated f)))) done + where+ step (Pair ss fs) i = do+ let + (ss', oldSplit, newSplits) = sstep ss i+ fs' <- step' fs oldSplit+ fs'' <- foldlM step'' fs' newSplits+ return $! Pair ss' fs''+ step' = L.foldM . duplicated+ step'' = \fs is -> reset fs >>= \fs' -> step' fs' is+ reset (FoldM _ fstate fdone) = + liftM (t . duplicated) (fstate >>= fdone) + done (Pair ss (FoldM fstep fstate fdone)) = do+ finalf <- fdone =<< flip (foldlM fstep) (sdone ss) =<< fstate+ L.foldM finalf [] ++{-| Summarizes each group detected by a 'Splitter' using a 'Fold', returning a+ 'Transduction' that allows a 'Fold' to accept the original ungrouped input. ++-}+folds :: Splitter i -> Fold i b -> Transduction i b+folds splitter f = groups splitter (transduce (chokepoint f))++foldsM :: Splitter i -> FoldM m i b -> TransductionM m i b+foldsM splitter f = groupsM splitter (transduceM (chokepointM f))++------------------------------------------------------------------------------++{-| Splits a stream into chunks of fixed size. ++>>> L.fold (folds (chunksOf 2) L.list L.list) [1..7]+[[1,2],[3,4],[5,6],[7]]++>>> L.fold (groups (chunksOf 2) (transduce (surround [] [0])) L.list) [1..7]+[1,2,0,3,4,0,5,6,0,7,0]+-}+chunksOf :: Int -> Splitter a+chunksOf 0 = Splitter (\_ _ -> ((),[],repeat [])) () (error "never happens")+chunksOf groupSize = Splitter step groupSize done + where+ step 0 a = (pred groupSize, [], [[a]])+ step i a = (pred i, [a], [])+ done _ = []++------------------------------------------------------------------------------++{- $reexports++-}
+ src/Control/Foldl/Transduce/Internal.hs view
@@ -0,0 +1,7 @@+module Control.Foldl.Transduce.Internal (+ -- * Strict datatypes + Pair(..)+ ) where++data Pair a b = Pair !a !b+
+ src/Control/Foldl/Transduce/Text.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}++-- |+--+-- This module builds on module "Control.Foldl.Text", adding stateful+-- transducers and grouping operations.+module Control.Foldl.Transduce.Text (+ -- * Decoding transducers+ decoder+ , utf8+ , utf8lenient + , utf8strict+ , decoderE+ , utf8E+ -- * Other transducers+ , newline+ , stripStart+ , stripEnd+ -- * Splitters+ , lines+ ) where++import Prelude hiding (lines)+import Data.Char+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 Control.Monad.Trans.Except+import Control.Monad.IO.Class+import Control.Exception.Base +import qualified Control.Foldl.Transduce as L+import Control.Foldl.Transduce.Internal (Pair(..))++{- $setup++>>> import Data.String hiding (lines)+>>> import Data.Text (Text)+>>> import Control.Monad.Trans.Except+>>> import qualified Control.Foldl as L+>>> import Control.Foldl.Transduce++-}++{-| Builds a decoding 'Transducer' out of a stream-oriented decoding function+ from "Data.Text.Encoding" and an error handler from+ "Data.Text.Encoding.Error". ++-}+decoder :: (B.ByteString -> T.Decoding) -> T.OnDecodeError -> L.Transducer B.ByteString T.Text ()+decoder _step onLeftovers = L.Transducer step (Pair mempty _step) done+ where+ step (Pair _ next) i = + let + T.Some txt leftovers next' = next i + in+ (Pair leftovers next', [txt])+ done (Pair leftovers _) = + if B.null leftovers+ then ((), [])+ else ((), foldMap (pure . T.singleton) onLeftovers')+ onLeftovers' = onLeftovers "leftovers" Nothing++{-| Builds a UTF8-decoding 'Transducer'. Takes an error handler from+ "Data.Text.Encoding.Error". ++-}+utf8 :: T.OnDecodeError -> L.Transducer B.ByteString T.Text ()+utf8 onDecodeError = + decoder (T.streamDecodeUtf8With onDecodeError) onDecodeError++{-| UTF8-decoding 'Transducer' that replaces invalid input bytes with the+ Unicode replacement character U+FFFD.++>>> L.fold (transduce utf8lenient L.list) (map fromString ["decode","this"])+["decode","this"]++>>> L.fold (transduce utf8lenient L.list) (map fromString ["across \xe2","\x98\x83 boundaries"])+["across ","\9731 boundaries"]++>>> L.fold (transduce utf8lenient L.list) (map fromString ["invalid \xc3\x28 sequence"])+["invalid \65533 sequence"]++>>> L.fold (transduce utf8lenient L.list) (map fromString ["incomplete \xe2"])+["incomplete ","\65533"]+-}+utf8lenient :: L.Transducer B.ByteString T.Text ()+utf8lenient = utf8 T.lenientDecode++{-| __/BEWARE!/__ + This 'Transducer' may throw 'UnicodeException'.+ __/BEWARE!/__ ++>>> L.fold (transduce utf8strict L.list) (map fromString ["invalid \xc3\x28 sequence"])+*** Exception: Cannot decode byte '\x28': Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream++>>> L.fold (transduce utf8strict L.list) (map fromString ["incomplete \xe2"])+*** Exception: Cannot decode input: leftovers+-}+utf8strict :: L.Transducer B.ByteString T.Text ()+utf8strict = utf8 T.strictDecode++{-| Similar to 'decoder', but catches 'UnicodeException' in 'IO' and uses+ 'Control.Monad.Trans.Except' to communicate the error. ++-}+decoderE :: MonadIO m+ => (T.OnDecodeError -> B.ByteString -> T.Decoding)+ -> L.TransducerM (ExceptT T.UnicodeException m) B.ByteString T.Text () +decoderE next = L.TransducerM step (pure (Pair mempty next')) done+ where+ step (Pair _ next1) i = do+ emc <- liftIO . try . evaluate $ next1 i + case emc of + Left ue -> do+ throwE ue+ Right (T.Some txt leftovers next2) -> do+ return (Pair leftovers next2, [txt])+ done (Pair leftovers _) = do+ if B.null leftovers+ then return ((), [])+ else do+ emc <- liftIO . try . evaluate $ onLeftovers'+ case emc of+ Left ue -> do+ throwE ue+ Right mc -> do+ return ((), foldMap (pure . T.singleton) mc)+ next' = next T.strictDecode + onLeftovers' = T.strictDecode "leftovers" Nothing++{-| Like 'utf8strict', but catches 'UnicodeException' in 'IO' and uses+ 'Control.Monad.Trans.Except' to communicate the error. ++>>> runExceptT $ L.foldM (transduceM utf8E (L.generalize L.list)) (map fromString ["invalid \xc3\x28 sequence"])+Left Cannot decode byte '\x28': Data.Text.Internal.Encoding.streamDecodeUtf8With: Invalid UTF-8 stream++>>> runExceptT $ L.foldM (transduceM utf8E (L.generalize L.list)) (map fromString ["incomplete \xe2"])+Left Cannot decode input: leftovers+-}+utf8E :: MonadIO m => L.TransducerM (ExceptT T.UnicodeException m) B.ByteString T.Text () +utf8E = decoderE T.streamDecodeUtf8With++{-| Appends a newline at the end of the stream. ++>>> L.fold (transduce newline L.list) (map T.pack ["without","newline"])+["without","newline","\n"]+-}+newline :: L.Transducer T.Text T.Text ()+newline = L.surround [] ["\n"]++blank :: T.Text -> Bool+blank = Data.Text.all isSpace++{-| Remove leading white space from a stream of 'Text'. ++>>> L.fold (transduce stripStart L.list) (map T.pack [" ","", " text "])+["text "]+-}+stripStart :: L.Transducer T.Text T.Text ()+stripStart = L.Transducer step False done+ where+ step True i = (True, [i])+ step False i =+ if blank i + then (False, [])+ else (True, [T.stripStart i])+ done _ = ((),[])++{-| Remove trailing white space from a stream of 'Text'. ++ __/BEWARE!/__ + This function naively accumulates in memory any arriving "blank blocks" of+ text until a non-blank block or end-of-stream arrives, and therefore it is+ potentially dangerous. Do not use with untrusted inputs.++>>> L.fold (transduce stripEnd L.list) (map T.pack [" ", " \n text ", " ", "" , " "])+[" "," \n text"]+-}+stripEnd :: L.Transducer T.Text T.Text ()+stripEnd = L.Transducer step [] done+ where+ step txts i =+ if blank i+ -- dangerous!+ then (i:txts, [])+ else ([i], reverse txts)+ done txts = case reverse txts of+ txt : _ -> ((), [T.stripEnd txt])+ _ -> ((), [])++{-| Splits a stream into lines, removing the newlines.++>>> L.fold (L.groups lines id L.list) (map T.pack ["line 1\n line 2\n"])+["line 1"," line 2"]++>>> L.fold (L.groups lines (transduce newline) L.list) (map T.pack ["line 1\n line 2\n"])+["line 1","\n"," line 2","\n"]+-}+lines :: L.Splitter T.Text+lines = L.Splitter step False done + where+ step previousnl txt | Data.Text.null txt = (previousnl,[],[]) + step previousnl txt = do+ let+ lastc = Data.Text.last txt == '\n'+ txts = T.lines txt+ case (previousnl,txts) of+ (_,[]) -> error "never happens"+ (True,_) -> (lastc, [], map pure txts)+ (False,t:ts) -> (lastc, [t], map pure ts)+ done _ = []+
+ tests/doctests.hs view
@@ -0,0 +1,10 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest + [+ "src/Control/Foldl/Transduce.hs",+ "src/Control/Foldl/Transduce/Text.hs"+ ]
+ tests/tests.hs view
@@ -0,0 +1,59 @@+module Main where++import Data.Monoid+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Text as T++import qualified Control.Foldl as L+import Control.Foldl.Transduce+import Control.Foldl.Transduce.Text++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = + testGroup "Tests" + [+ testGroup "surround" + [+ testCase "surroundempty" $ + assertEqual mempty+ "prefixsuffix"+ (L.fold (transduce (surround "prefix" "suffix") L.list) "")+ ]+ ,+ testGroup "chunksOf" + [+ testCase "emptyList3" $ + assertEqual mempty+ ([[]]::[[Int]])+ (L.fold (folds (chunksOf 3) L.list L.list) [])+ ,+ testCase "size1" $ + assertEqual mempty+ ([[1],[2],[3],[4],[5],[6],[7]]::[[Int]])+ (L.fold (folds (chunksOf 1) L.list L.list) [1..7])+ ,+ testCase "size3" $ + assertEqual mempty+ ([[1,2,3],[4,5,6],[7]]::[[Int]])+ (L.fold (folds (chunksOf 3) L.list L.list) [1..7])+ ]+ ,+ testGroup "newline" $ + [+ testCase "newlineempty" $+ assertEqual mempty+ (T.pack "\n")+ (mconcat (L.fold (transduce newline L.list) (map T.pack [])))+ ,+ testCase "newlinenull" $+ assertEqual mempty+ (T.pack "\n")+ (mconcat (L.fold (transduce newline L.list) (map T.pack [""])))+ ]+ ]+