foldl-transduce 0.6.0.0 → 0.6.0.1
raw patch · 11 files changed
+2273/−2278 lines, 11 filesdep ~criteriondep ~monoid-subclassessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: criterion, monoid-subclasses
API changes (from Hackage documentation)
- Control.Foldl.Transduce: instance (m ~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.MooreM m')
- Control.Foldl.Transduce: instance (m ~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.ReifiedTransductionM' m')
- Control.Foldl.Transduce: instance (m ~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.TransducerM m')
- Control.Foldl.Transduce: instance m ~ m' => Control.Foldl.Transduce.ToFoldM m (Control.Foldl.FoldM m')
- Control.Foldl.Transduce: instance m ~ m' => Control.Foldl.Transduce.ToTransducerM m (Control.Foldl.Transduce.TransducerM m')
+ Control.Foldl.Transduce: Fold :: (x -> a -> x) -> x -> (x -> b) -> Fold a b
+ Control.Foldl.Transduce: FoldM :: (x -> a -> m x) -> m x -> (x -> m b) -> FoldM (m :: Type -> Type) a b
+ Control.Foldl.Transduce: data Fold a b
+ Control.Foldl.Transduce: data FoldM (m :: Type -> Type) a b
+ Control.Foldl.Transduce: hoists :: (forall x. () => m x -> n x) -> FoldM m a b -> FoldM n a b
+ Control.Foldl.Transduce: instance (m GHC.Types.~ m') => Control.Foldl.Transduce.ToFoldM m (Control.Foldl.FoldM m')
+ Control.Foldl.Transduce: instance (m GHC.Types.~ m') => Control.Foldl.Transduce.ToTransducerM m (Control.Foldl.Transduce.TransducerM m')
+ Control.Foldl.Transduce: instance (m GHC.Types.~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.MooreM m')
+ Control.Foldl.Transduce: instance (m GHC.Types.~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.ReifiedTransductionM' m')
+ Control.Foldl.Transduce: instance (m GHC.Types.~ m', GHC.Base.Monad m') => Control.Foldl.Transduce.ToTransductionsM' m (Control.Foldl.Transduce.TransducerM m')
- Control.Foldl.Transduce: TransducerM :: (x -> i -> m (x, [o], [[o]])) -> (m x) -> (x -> m (r, [o], [[o]])) -> TransducerM m i o r
+ Control.Foldl.Transduce: TransducerM :: (x -> i -> m (x, [o], [[o]])) -> m x -> (x -> m (r, [o], [[o]])) -> TransducerM m i o r
- Control.Foldl.Transduce: transduceK :: (Monad m) => (i -> m [o]) -> TransductionM m i o
+ Control.Foldl.Transduce: transduceK :: Monad m => (i -> m [o]) -> TransductionM m i o
- Control.Foldl.Transduce.ByteString: toHandle :: (MonadIO m) => Handle -> FoldM m ByteString ()
+ Control.Foldl.Transduce.ByteString: toHandle :: MonadIO m => Handle -> FoldM m ByteString ()
- Control.Foldl.Transduce.ByteString: toHandleBuilder :: (MonadIO m) => Handle -> FoldM m Builder ()
+ Control.Foldl.Transduce.ByteString: toHandleBuilder :: MonadIO m => Handle -> FoldM m Builder ()
Files
- CHANGELOG +98/−98
- LICENSE +28/−28
- README.md +38/−38
- Setup.hs +0/−2
- benchmarks/benchmarks.hs +21/−21
- foldl-transduce.cabal +89/−85
- src/Control/Foldl/Transduce.hs +1121/−1128
- src/Control/Foldl/Transduce/ByteString.hs +88/−88
- src/Control/Foldl/Transduce/Text.hs +536/−536
- tests/doctests.hs +11/−11
- tests/tests.hs +243/−243
CHANGELOG view
@@ -1,98 +1,98 @@-# 0.6.0.0--- Update to match change in foldl library.--# 0.5.1.0--- Removed upper bounds in dependencies.--# 0.5.0.0--- Before, splitters always found at least one group, even for empty streams.- Now, no groups are found for empty streams.-- Made some type signatures a bit more strict.-- Eliminated previously deprecated functions and modules.--# 0.4.7.0--- Added "sections" splitter.-- Deprecated Control.Foldl.Transduce.Textual--# 0.4.6.0--- Deprecated Control.Foldl.Transduce.ByteString.IO -- Added Control.Foldl.Transduce.ByteString-- Added "paragraphs" splitter.--# 0.4.5.0--- added split--# 0.4.4.0--- deprecated quiesceWith-- added Fallible.--# 0.4.3.0--- deprecated splitWhen in favor of break-- deprecated textualSplitWhen in favor of textualBreak--# 0.4.2.0--- Added "trip" fold.-- Added Control.Foldl.Transduce.Textual.--# 0.4.1.0--- Added module Control.Foldl.Transduce.ByteString.IO, to- avoid having to depend on other packages for simple I/O tasks.-- Added "unit" fold.--# 0.4.0.0--- Changed order of parameters for groups' and groupsM'. Hopefully the new one- is clearer.-- It was annoying to use "evenly (transduce ...)" every time. Added new- ToTransductions' typeclass for types that can be converted to an infinite- list of transductions.-- Added ToFold typeclass as well.--# 0.3.0.0--- Transducers can now delimit segments in the done function, too.- This was required for transducers like surround to work as splitters.-- Strengthened the constraints on the surround function to Traversable.-- Added dependency on free and monoid-subclasses.-- group functions can now treat each group differently.-- Added ignore, splitAt, splitWhen, splitLast-- removed drop, take... use splitAt, splitWhen + bisect.-- Added bisect, evenly convenience functions.--# 0.2.1.0--- Comonad and Extend instances for Transducer -- Added words splitter-- Added take, drop, takeWhile, dropWhile transducers--# 0.2.0.0--- Removed the Spliiter type. Now it's transducers for everything!-- generalizeTransducer -> _generalize-- simplifyTransducer -> _simplify-- removed chokepoint and chokepointM---# 0.1.2.0--- Added explicit bifunctors dependency.-- Added Transduce', TransduceM' type synonyms.-- Added groups', groupsM'.---# 0.1.1.0--- Changed signatures of transduce' and transduceM'.-- generalize' -> generalizeTransducer-- simplify' -> simplifyTransducer-- dropped direct profunctors dependency.+# 0.6.0.0 + +- Update to match change in foldl library. + +# 0.5.1.0 + +- Removed upper bounds in dependencies. + +# 0.5.0.0 + +- Before, splitters always found at least one group, even for empty streams. + Now, no groups are found for empty streams. +- Made some type signatures a bit more strict. +- Eliminated previously deprecated functions and modules. + +# 0.4.7.0 + +- Added "sections" splitter. +- Deprecated Control.Foldl.Transduce.Textual + +# 0.4.6.0 + +- Deprecated Control.Foldl.Transduce.ByteString.IO +- Added Control.Foldl.Transduce.ByteString +- Added "paragraphs" splitter. + +# 0.4.5.0 + +- added split + +# 0.4.4.0 + +- deprecated quiesceWith +- added Fallible. + +# 0.4.3.0 + +- deprecated splitWhen in favor of break +- deprecated textualSplitWhen in favor of textualBreak + +# 0.4.2.0 + +- Added "trip" fold. +- Added Control.Foldl.Transduce.Textual. + +# 0.4.1.0 + +- Added module Control.Foldl.Transduce.ByteString.IO, to + avoid having to depend on other packages for simple I/O tasks. +- Added "unit" fold. + +# 0.4.0.0 + +- Changed order of parameters for groups' and groupsM'. Hopefully the new one + is clearer. +- It was annoying to use "evenly (transduce ...)" every time. Added new + ToTransductions' typeclass for types that can be converted to an infinite + list of transductions. +- Added ToFold typeclass as well. + +# 0.3.0.0 + +- Transducers can now delimit segments in the done function, too. + This was required for transducers like surround to work as splitters. +- Strengthened the constraints on the surround function to Traversable. +- Added dependency on free and monoid-subclasses. +- group functions can now treat each group differently. +- Added ignore, splitAt, splitWhen, splitLast +- removed drop, take... use splitAt, splitWhen + bisect. +- Added bisect, evenly convenience functions. + +# 0.2.1.0 + +- Comonad and Extend instances for Transducer +- Added words splitter +- Added take, drop, takeWhile, dropWhile transducers + +# 0.2.0.0 + +- Removed the Spliiter type. Now it's transducers for everything! +- generalizeTransducer -> _generalize +- simplifyTransducer -> _simplify +- removed chokepoint and chokepointM + + +# 0.1.2.0 + +- Added explicit bifunctors dependency. +- Added Transduce', TransduceM' type synonyms. +- Added groups', groupsM'. + + +# 0.1.1.0 + +- Changed signatures of transduce' and transduceM'. +- generalize' -> generalizeTransducer +- simplify' -> simplifyTransducer +- dropped direct profunctors dependency.
LICENSE view
@@ -1,28 +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.-+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. +
README.md view
@@ -1,38 +1,38 @@-## What's in this library?--Stateful transducers and streaming-preserving group operations for the folds in-Gabriel Gonzalez's [foldl](http://hackage.haskell.org/package/foldl) package.--## When to use this library?--- When you want to wrap a stateful decoder over a **Fold**. An example is-decoding UTF-8: the decoder must be stateful because a multi-byte character may-have been split across two blocks of bytes.--- When you want to tweak the stream of data that arrives into a **Fold**, but-only at certain positions. Stripping whitespace at the beginning of a text-stream, for example.--- When you want to perform group operations without breaking "streaminess",-similar to what [pipes-group](http://hackage.haskell.org/package/pipes-group)-does.--## Why use this library for grouping instead of **pipes-group**?--Grouping fold-side instead of producer-side has the advantage that, since the-results are still **Fold**s, you can combine them using **Applicative**.--Also, **Fold**s can work with sources other than **Producer**s from pipes.--Grouping fold-side has limitations as well:--- You can't perform bracketing operations like "withFile" that span the folding- of an entire group. pipes-group allows them.--- You have more flexibility in pipes-group to decide how to delimit and fold- the next group based on previous results.---## Where can I find working examples for this library?--In the [examples](https://github.com/danidiaz/foldl-transduce/tree/master/examples) folder of the repo.+## What's in this library? + +Stateful transducers and streaming-preserving group operations for the folds in +Gabriel Gonzalez's [foldl](http://hackage.haskell.org/package/foldl) package. + +## When to use this library? + +- When you want to wrap a stateful decoder over a **Fold**. An example is +decoding UTF-8: the decoder must be stateful because a multi-byte character may +have been split across two blocks of bytes. + +- When you want to tweak the stream of data that arrives into a **Fold**, but +only at certain positions. Stripping whitespace at the beginning of a text +stream, for example. + +- When you want to perform group operations without breaking "streaminess", +similar to what [pipes-group](http://hackage.haskell.org/package/pipes-group) +does. + +## Why use this library for grouping instead of **pipes-group**? + +Grouping fold-side instead of producer-side has the advantage that, since the +results are still **Fold**s, you can combine them using **Applicative**. + +Also, **Fold**s can work with sources other than **Producer**s from pipes. + +Grouping fold-side has limitations as well: + +- You can't perform bracketing operations like "withFile" that span the folding + of an entire group. pipes-group allows them. + +- You have more flexibility in pipes-group to decide how to delimit and fold + the next group based on previous results. + + +## Where can I find working examples for this library? + +In the [examples](https://github.com/danidiaz/foldl-transduce/tree/master/examples) folder of the repo.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
benchmarks/benchmarks.hs view
@@ -1,21 +1,21 @@-module Main where--import Data.Foldable-import qualified Control.Foldl as L-import Control.Foldl.Transduce-import Lens.Family--import Criterion.Main--main :: IO ()-main = defaultMain [- bgroup "sum" [- bench "without trans" (nf - (L.fold L.sum)- (take 500000 (cycle [1::Int,-1])))- ,- bench "with trans" (nf - (L.fold (folds (chunksOf 1) L.list (L.handles (folding toList) L.sum)))- (take 500000 (cycle [1::Int,-1])))- ] - ]+module Main where + +import Data.Foldable +import qualified Control.Foldl as L +import Control.Foldl.Transduce +import Lens.Family + +import Criterion.Main + +main :: IO () +main = defaultMain [ + bgroup "sum" [ + bench "without trans" (nf + (L.fold L.sum) + (take 500000 (cycle [1::Int,-1]))) + , + bench "with trans" (nf + (L.fold (folds (chunksOf 1) L.list (L.handles (folding toList) L.sum))) + (take 500000 (cycle [1::Int,-1]))) + ] + ]
foldl-transduce.cabal view
@@ -1,85 +1,89 @@-Name: foldl-transduce-Version: 0.6.0.0-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 foldl folds.-Description: Stateful transducers and streaming-preserving grouping operations for foldl folds.-Category: Control--Extra-Source-Files:- README.md- CHANGELOG--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 ,- text >= 0.11.2.0 ,- transformers >= 0.2.0.0 ,- containers ,- bifunctors >= 5 ,- profunctors >= 5 ,- semigroups >= 0.18 ,- semigroupoids >= 5.0 ,- foldl >= 1.4 ,- comonad >= 4 ,- free >= 4 , - void >= 0.6 ,- split >= 0.2.2 ,- monoid-subclasses == 0.4.* - Exposed-Modules:- Control.Foldl.Transduce,- Control.Foldl.Transduce.ByteString,- Control.Foldl.Transduce.Text- 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- , free >= 4- , 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,- tasty-quickcheck >= 0.8.3.2, - monoid-subclasses >= 0.4,- split >= 0.2.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,- lens-family-core >= 1.2.0 ,- foldl ,- foldl-transduce+Cabal-Version: 3.0 +Name: foldl-transduce +Version: 0.6.0.1 +Build-Type: Simple +License: BSD-3-Clause +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 foldl folds. +Description: Stateful transducers and streaming-preserving grouping operations for foldl folds. +Category: Control + +Extra-Source-Files: + README.md + CHANGELOG + +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 , + text >= 0.11.2.0 , + transformers >= 0.2.0.0 , + containers , + bifunctors >= 5 , + profunctors >= 5 , + semigroups >= 0.18 , + semigroupoids >= 5.0 , + foldl >= 1.4 , + comonad >= 4 , + free >= 4 , + void >= 0.6 , + split >= 0.2.2 , + monoid-subclasses >= 1.1 + Exposed-Modules: + Control.Foldl.Transduce, + Control.Foldl.Transduce.ByteString, + Control.Foldl.Transduce.Text + GHC-Options: -O2 -Wall + default-language: Haskell2010 + +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 + , free >= 4 + , doctest >= 0.10.1 + default-language: Haskell2010 + +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, + tasty-quickcheck >= 0.8.3.2, + monoid-subclasses >= 1.1, + split >= 0.2.2, + foldl , + foldl-transduce + default-language: Haskell2010 + +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.6, + lens-family-core >= 1.2.0 , + foldl , + foldl-transduce + default-language: Haskell2010
src/Control/Foldl/Transduce.hs view
@@ -1,1128 +1,1121 @@-{-# LANGUAGE ExistentialQuantification, RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}--{-| This module builds on module "Control.Foldl", adding stateful transducers- and grouping operations.-->>> L.fold (transduce (surround "[" "]") L.list) "middle"-"[middle]"-->>> L.fold (folds (chunksOf 2) L.length L.list) "aabbccdd"-[2,2,2,2]-->>> L.fold (groups (chunksOf 2) (surround "[" "]") L.list) "aabbccdd"-"[aa][bb][cc][dd]"---}--module Control.Foldl.Transduce (- -- * Transducer types- Transduction - , Transduction' - , Transducer(..)- , ToTransducer(..)- -- ** Monadic transducer types- , TransductionM- , TransductionM'- , TransducerM(..)- , ToTransducerM(..)- -- * Applying transducers- , transduce- , transduce'- , transduceM- , transduceM'- , transduceK- -- * Folding over groups- , folds- , folds'- , foldsM- , foldsM'- -- * Group operations- , ReifiedTransduction' (..)- , reify- , reify'- , Moore(..)- , ToTransductions' (..)- , moveHead- , groups- , bisect- , groups'- -- ** Monadic group operations- , ReifiedTransductionM' (..)- , reifyM- , reifyM'- , MooreM(..)- , ToTransductionsM' (..)- , moveHeadM- , groupsM- , bisectM- , groupsM'- -- * Transducers- , ignore- , surround- , surroundIO- -- * Splitters- , chunksOf- , split- , splitAt- , chunkedSplitAt- , splitLast- , break- , chunkedStripPrefix- -- * Transducer utilities- , foldify- , foldifyM- , condense- , condenseM- , hoistTransducer- -- * Fold utilities- , hoistFold- , unit- , trip- , quiesce- , Fallible(..)- , ToFold(..)- , ToFoldM(..)- -- * Deprecated- -- * Re-exports- -- $reexports- , module Data.Functor.Extend- , module Control.Foldl- , module Control.Comonad.Cofree- ) where--import Prelude hiding (split,splitAt,break)--import Data.Functor-import Data.Bifunctor-import Data.Profunctor-import Data.Monoid-import Data.Void-import qualified Data.Monoid.Cancellative as CM-import qualified Data.Monoid.Null as NM-import qualified Data.Monoid.Factorial as SFM-import Data.Functor.Identity-import Data.Functor.Extend-import Data.Foldable (Foldable,foldlM,foldl',toList)-import Data.Traversable-import Control.Applicative-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import Control.Comonad-import Control.Comonad.Cofree -import Control.Foldl (Fold(..),FoldM(..),hoists)-import qualified Control.Foldl as L--{- $setup-->>> import qualified Control.Foldl as L->>> import Control.Foldl.Transduce->>> import Control.Applicative->>> import qualified Control.Comonad.Cofree as C->>> import Prelude hiding (split,splitAt,break)---}----------------------------------------------------------------------------------#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 -> return $! FoldM step (return x) done)- {-# INLINABLE duplicated #-}----------------------------------------------------------------------------------data Pair a b = Pair !a !b--data Quartet a b c d = Quartet !a !b !c !d--fst3 :: (a,b,c) -> a-fst3 (x,_,_) = x----------------------------------------------------------------------------------{-| A (possibly stateful) transformation on the inputs of a 'Fold'.-- Functions constructed with combinators like 'L.premap' or 'L.handles' from- "Control.Foldl" also typecheck as a 'Transduction'.--}-type Transduction a b = forall x. Fold b x -> Fold a x--{-| A more general from of 'Transduction' that adds new information to the- return value of the 'Fold'.---}-type Transduction' a b r = forall x. Fold b x -> Fold a (r,x)--{-| Helper for storing a 'Transduction'' safely on a container. ---}-newtype ReifiedTransduction' a b r = ReifiedTransduction' { getTransduction' :: Transduction' a b r }--{-| Convenience constructor, often useful with pure functions like 'id'. ---}-reify :: Transduction a b -> ReifiedTransduction' a b ()-reify t = reify' (fmap (fmap ((,) ())) t) --reify' :: Transduction' a b r -> ReifiedTransduction' a b r-reify' = ReifiedTransduction' --{-| A stateful process that transforms a stream of inputs into a stream of- outputs, and may optionally demarcate groups in the stream of outputs.-- Composed of a step function, an initial state, and a extraction function. -- The step function returns a triplet of:-- * The new internal state.- * List of outputs belonging to the last segment detected in the previous step.- * A list of lists of outputs belonging to segments detected in the current- step. If the list is empty, that means no splitting has taken place in the- current step. 'Transducer's that do not perform grouping never return anything- other than @[]@ here. In effect, they treat the whole stream as a single group.-- The extraction function returns the 'Transducer's own result value, along with any- pending output.--}-data Transducer i o r- = forall x. Transducer (x -> i -> (x,[o],[[o]])) x (x -> (r,[o],[[o]]))--instance Comonad (Transducer i o) where- extract (Transducer _ begin done) = fst3 (done begin)- {-# INLINABLE extract #-}-- duplicate (Transducer step begin done) = Transducer step begin (\x -> (Transducer step x done,[],[]))- {-# INLINABLE duplicate #-}--instance Extend (Transducer i o) where- duplicated f = duplicate f- {-# INLINABLE duplicated #-}--instance Functor (Transducer i o) where- fmap f (Transducer step begin done) = - Transducer - step - begin - ((\(x,xs,xss) -> (f x,xs,xss)) . done)--instance Bifunctor (Transducer i) where- first f (Transducer step begin done) =- Transducer - (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . step) - begin - ((\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done) - second f w = fmap f w--{-| Helps converting monadic transducers (over 'Identity') into pure ones. ---}-class ToTransducer t where- toTransducer :: t i o r -> Transducer i o r--instance ToTransducer Transducer where- toTransducer = id--instance ToTransducer (TransducerM Identity) where- toTransducer = _simplify--class ToFold t where- toFold :: t i r -> Fold i r--instance ToFold Fold where- toFold = id--instance ToFold (FoldM Identity) where- toFold = L.simplify--{-| Like 'Transduction', but works on monadic 'Fold's. ---}-type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x--{-| Like 'Transduction'', but works on monadic 'Fold's. ---}-type TransductionM' m a b r = forall x. FoldM m b x -> FoldM m a (r,x)--{-| Helper for storing a 'TransductionM'' safely on a container. ---}-newtype ReifiedTransductionM' m a b r = ReifiedTransductionM' { getTransductionM' :: TransductionM' m a b r }--{-| Monadic version of 'reify'. ---}-reifyM :: Monad m => TransductionM m a b -> ReifiedTransductionM' m a b ()-reifyM t = reifyM' (fmap (fmap ((,) ())) t) --{-| Monadic version of 'reifyM'. ---}-reifyM' :: TransductionM' m a b r -> ReifiedTransductionM' m a b r-reifyM' = ReifiedTransductionM' --{-| Like 'Transducer', but monadic.---}-data TransducerM m i o r- = forall x. TransducerM (x -> i -> m (x,[o],[[o]])) (m x) (x -> m (r,[o],[[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,oss) <- done x- let r' = f r- return $! (r' `seq` (r',os,oss))--instance (Functor m, Monad m) => Bifunctor (TransducerM m i) where- first f (TransducerM step begin done) =- TransducerM - (fmap (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss))) . step) - begin - (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done) - second f w = fmap f w--instance Monad m => Extend (TransducerM m i o) where- duplicated (TransducerM step begin done) = - TransducerM step begin (\x -> return $! (TransducerM step (return x) done,[],[]))- {-# INLINABLE duplicated #-}---{-| Helps converting pure transducers into monadic ones. ---}-class ToTransducerM m t where- toTransducerM :: t i o r -> TransducerM m i o r---- http://chrisdone.com/posts/haskell-constraint-trick-instance (m ~ m') => ToTransducerM m (TransducerM m') where- toTransducerM = id--instance Monad m => ToTransducerM m Transducer where- toTransducerM = _generalize--class ToFoldM m t where- toFoldM :: t i r -> FoldM m i r--instance (m ~ m') => ToFoldM m (FoldM m') where- toFoldM = id--instance Monad m => ToFoldM m Fold where- toFoldM = L.generalize---{-| Apply a 'Transducer' to a 'Fold', discarding the return value of the- 'Transducer'. -->>> L.fold (transduce (Transducer (\_ i -> ((),[i],[])) () (\_ -> ((),[],[]))) L.list) [1..7]-[1,2,3,4,5,6,7]--}-transduce :: ToTransducer t => t i o () -> Transduction i o -transduce t = fmap snd . (transduce' t)--{-| Generalized version of 'transduce' that preserves 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' :: ToTransducer t => t i o s -> Transduction' i o s-transduce' (toTransducer -> Transducer wstep wstate wdone) (Fold fstep fstate fdone) =- Fold step (Pair wstate fstate) done - where- step (Pair ws fs) i = - let (ws',os,oss) = wstep ws i - in- Pair ws' (foldl' fstep fs (os ++ mconcat oss)) - done (Pair ws fs) = - let (wr,os,oss) = wdone ws- in - (,) wr (fdone (foldl' fstep fs (os ++ mconcat oss)))---{-| Like 'transduce', but works on monadic 'Fold's. ---}-transduceM :: (Monad m, ToTransducerM m t) => t i o () -> TransductionM m i o -transduceM t = fmap snd . (transduceM' t)--{-| Like 'transduce'', but works on monadic 'Fold's. ---}-transduceM' :: (Monad m, ToTransducerM m t) => t i o s -> TransductionM' m i o s-transduceM' (toTransducerM -> TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) =- FoldM step (liftM2 Pair wstate fstate) done - where- step (Pair ws fs) i = do- (ws',os,oss) <- wstep ws i- fs' <- foldlM fstep fs (os ++ mconcat oss)- return $! Pair ws' fs'- done (Pair ws fs) = do- (wr,os,oss) <- wdone ws- fr <- fdone =<< foldlM fstep fs (os ++ mconcat oss)- return $! (,) wr fr--{-| Transduce with a Kleisli arrow that returns a list. ---}-transduceK :: (Monad m) => (i -> m [o]) -> TransductionM m i o -transduceK k = transduceM (TransducerM step (return ()) (\_ -> return ((),[],[])))- where- step _ i = liftM (\os -> ((),os,[])) (k i)-----------------------------------------------------------------------------------{-| Ignore all the inputs coming into the fold.-- Polymorphic in both inputs and outputs. ---}-ignore :: Transducer a b ()-ignore = - Transducer step () done - where- step _ _ = - ((),[],[])- done = - const ((),[],[])--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"-- Used as a splitter, it puts the prefix, the original stream and- the suffix in separate groups:-->>> L.fold (groups (surround "prefix" "suffix") (surround "[" "]") L.list) "middle"-"[prefix][middle][suffix]"---}-surround :: (Traversable p, Traversable 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 :: (Traversable p, Traversable s, Functor m, 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 ((), ps, [[],ss])- done PrefixAdded = do- ss <- fmap toList suffixa- return ((), [], [ss])----------------------------------------------------------------------------------{-| Generalize a 'Transducer' to a 'TransducerM'. ---}-_generalize :: Monad m => Transducer i o s -> TransducerM m i o s-_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 s -> Transducer i o s-_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 s -> Fold i s-foldify (Transducer step begin done) =- Fold (\x i -> fst3 (step x i)) begin (\x -> fst3 (done x))--{-| Monadic version of 'foldify'. ---}-foldifyM :: Functor m => TransducerM m i o s -> FoldM m i s-foldifyM (TransducerM step begin done) =- FoldM (\x i -> fmap fst3 (step x i)) begin (\x -> fmap fst3 (done x))--{-| Transforms a 'Fold' into a 'Transducer' that sends the return value of the- 'Fold' downstream when upstream closes. ---}-condense :: Fold a r -> Transducer a r r-condense (Fold fstep fstate fdone) =- (Transducer wstep fstate wdone)- where- wstep = \fstate' i -> (fstep fstate' i,[],[])- wdone = \fstate' -> (\r -> (r,[r],[])) (fdone fstate')--{-| Monadic version of 'condense'. ---}-condenseM :: Applicative m => FoldM m a r -> TransducerM m a r r-condenseM (FoldM fstep fstate fdone) = - (TransducerM wstep fstate wdone)- where- wstep = \fstate' i -> fmap (\s -> (s,[],[])) (fstep fstate' i)- wdone = \fstate' -> fmap (\r -> (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 s -> TransducerM n i o s -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'. -- Another name for 'Control.Foldl.hoists'.--}-hoistFold :: Monad m => (forall a. m a -> n a) -> FoldM m i r -> FoldM n i r -hoistFold = Control.Foldl.hoists--{-| Turn a 'FoldM' that fails abruptly into one that encodes the error into- its return value.-- Can be useful when combining fallible 'FoldM's with non-fallible ones.-->>> L.foldM (quiesce (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7]-Left ()--}-quiesce :: Monad m => FoldM (ExceptT e m) a r -> FoldM m a (Either e r)-quiesce (FoldM step initial done) = - FoldM step' (runExceptT initial) done'- where- step' x i = do - case x of- Left _ -> return x- Right notyetfail -> runExceptT (step notyetfail i)- done' x = do- case x of - Left e -> return (Left e)- Right notyetfail -> do- result <- runExceptT (done notyetfail)- case result of - Left e -> return (Left e)- Right r -> return (Right r)--newtype Fallible m r i e = Fallible { getFallible :: FoldM (ExceptT e m) i r }--bindFallible :: (Functor m,Monad m) => Fallible m r i e -> (e -> Fallible m r i e') -> Fallible m r i e'-bindFallible (Fallible (FoldM step initial done)) k =- Fallible (FoldM step' (lift (runExceptT (withExceptT (getFallible . k) initial))) done')- where - step' x i = ExceptT (case x of- Left ffold -> do- rx <- runExceptT (L.foldM (duplicated ffold) [i])- case rx of- Left e' -> return (Left e') -- true failure- Right ffold' -> return (Right (Left ffold'))- Right notyetfail -> do- x' <- runExceptT (step notyetfail i)- case x' of- Left e -> do- return (Right (Left ((getFallible . k) e)))- Right x'' -> return (Right (Right x'')))- done' x = ExceptT (case x of- Left ffold -> do- rx <- runExceptT (L.foldM ffold [])- case rx of- Left e' -> return (Left e') -- true failure- Right r -> return (Right r)- Right notyetfail -> do- x' <- runExceptT (done notyetfail)- case x' of- Left e -> do- runExceptT (done' (Left (getFallible (k e))))- Right x'' -> return (Right x''))--instance (Functor m, Monad m) => Functor (Fallible m r i) where- fmap g (Fallible fallible) = - Fallible (hoistFold (withExceptT g) fallible)---{-| 'pure' creates a 'Fallible' that starts in a failed state. ---}-instance (Functor m,Monad m) => Applicative (Fallible m r i) where- pure e = Fallible (FoldM (\_ _ -> throwE e) (throwE e) (\_ -> throwE e))-- u <*> v = u >>= \f -> fmap f v--instance (Functor m, Monad m) => Profunctor (Fallible m r) where- lmap f (Fallible fallible) = - Fallible (L.premapM (return . f) fallible)-- rmap g (Fallible fallible) = - Fallible (hoistFold (withExceptT g) fallible)--{-| Fail immediately when an input comes in the wrong branch. ---}-instance (Functor m,Monad m,Monoid r) => Choice (Fallible m r) where- left' (Fallible fallible) = - Fallible (liftA2 mappend (hoistFold (withExceptT Left) (L.handlesM _Left fallible)) (hoistFold (withExceptT Right) (L.handlesM _Right (trip $> mempty))))--_Left :: Applicative f => (a -> f a) -> Either a b -> f (Either a b)-_Left f e = case e of- Right b -> pure (Right b)- Left a -> fmap Left (f a)--_Right :: Applicative f => (b -> f b) -> Either a b -> f (Either a b)-_Right f e = case e of- Left b -> pure (Left b)- Right a -> fmap Right (f a)--{-| '>>=' continues folding after an error using a 'Fallible' constructed from the error. ---}-instance (Functor m,Monad m) => Monad (Fallible m r i) where- (>>=) = bindFallible- return = pure--{-| The "do-nothing" fold. ---}-unit :: Fold a ()-unit = pure () --{-| A fold that fails if it receives any input at all. The received input is- used as the error. ---}-trip :: Monad m => FoldM (ExceptT a m) a ()-trip = FoldM (\_ x -> throwE x) (return ()) (\_ -> return mempty)----------------------------------------------------------------------------------{-| An unending machine that eats @u@ values and returns - 'ReifiedTransduction''s whose result type is also @u@.---}-newtype Moore a b u = Moore { getMoore :: Cofree ((->) u) (ReifiedTransduction' a b u) }--{-| Monadic version of 'Moore'. ---}-newtype MooreM m a b u = MooreM { getMooreM :: Cofree ((->) u) (ReifiedTransductionM' m a b u) }--{-| Prepend the head of the first argument to the second argument. ---}-moveHead :: (ToTransductions' h,ToTransductions' t) => h a b u -> t a b u -> Moore a b u -moveHead (toTransductions' -> Moore (theHead :< _)) (toTransductions' -> Moore theTail) = Moore (theHead :< const theTail)--{-| Monadic version of 'moveHead'. ---}-moveHeadM :: (Monad m, ToTransductionsM' m h, ToTransductionsM' m t) => h a b u -> t a b u -> MooreM m a b u -moveHeadM (toTransductionsM' -> MooreM (theHead :< _)) (toTransductionsM' -> MooreM theTail) = MooreM (theHead :< const theTail)--{-| Helper for obtaining infinite sequences of 'Transduction''s from suitable- types (in order to avoid explicit conversions). ---}-class ToTransductions' t where- toTransductions' :: t a b u -> Moore a b u--instance ToTransductions' Moore where- toTransductions' = id--instance ToTransductions' Transducer where- toTransductions' t = toTransductions' (reify' (transduce' t))--instance ToTransductions' ReifiedTransduction' where- toTransductions' = Moore . coiter const--{-| Monadic version of 'ToTransductions''. ---}-class Monad m => ToTransductionsM' m t where- toTransductionsM' :: t a b u -> MooreM m a b u--instance (m ~ m', Monad m') => ToTransductionsM' m (MooreM m') where- toTransductionsM' = id--instance (m ~ m', Monad m') => ToTransductionsM' m (TransducerM m') where- toTransductionsM' t = toTransductionsM' (reifyM' (transduceM' t))--instance Monad m => ToTransductionsM' m Transducer where- toTransductionsM' (toTransducerM -> t) = toTransductionsM' (reifyM' (transduceM' t))--instance (m ~ m', Monad m') => ToTransductionsM' m (ReifiedTransductionM' m') where- toTransductionsM' = MooreM . coiter const--{-| Processes each of the groups demarcated by a 'Transducer' using - a 'Transduction' taken from an unending supply, - returning a 'Transduction' what works over the undivided stream of inputs. - - The return value of the 'Transducer' is discarded.-->>> L.fold (groups (chunksOf 2) (surround "<" ">") L.list) "aabbccdd"-"<aa><bb><cc><dd>"-->>> :{ - let transductions = Moore (C.unfold (\i ->- (reify (transduce (surround (show i) [])), \_ -> succ i)) 0)- in L.fold (groups (chunksOf 2) transductions L.list) "aabbccdd"- :}-"0aa1bb2cc3dd"--}-groups :: (ToTransducer s, ToTransductions' t) - => s a b () -- ^ 'Transducer' working as a splitter.- -> t b c () -- ^ infinite list of transductions- -> Transduction a c -groups splitter transductions oldfold = - fmap snd (groups' splitter transductions unit oldfold)--{-| Use a different 'Transduction' for the first detected group. -->>> :{ - let drop n = bisect (splitAt n) ignore (reify id)- in L.fold (drop 2 L.list) "aabbccdd"- :}-"bbccdd"--}-bisect :: (ToTransducer s, ToTransductions' h, ToTransductions' t)- => s a b () -- ^ 'Transducer' working as a splitter.- -> h b c () -- ^ Machine to process the first group- -> t b c () -- ^ Machine to process the second and subsequent groups- -> Transduction a c-bisect sp t1 t2 = groups sp (moveHead t1 t2)--data StrictSum a b = Left' !a | Right' !b--{-| Generalized version of 'groups' that preserves the return value of the- 'Transducer'.-- A summary value for each group is also calculated. These values are - aggregated for the whole stream, with the help of an auxiliary 'Fold'.--->>> :{ - let transductions = - reify' (\f -> transduce (surround "<" ">") ((,) <$> L.list <*> f))- in L.fold (groups' (chunksOf 2) transductions L.list L.list) "aabbccdd"- :}-(((),["<aa>","<bb>","<cc>","<dd>"]),"<aa><bb><cc><dd>")--}-groups' :: (ToTransducer s, ToTransductions' t, ToFold f)- => s a b r -- ^ 'Transducer' working as a splitter. - -> t b c u -- ^ machine that eats @u@ values and spits transductions- -> f u v -- ^ auxiliary 'Fold' that aggregates the @u@ values produced for each group- -> Transduction' a c (r,v) -groups' (toTransducer -> Transducer sstep sbegin sdone) - (toTransductions' -> Moore (rt0 :< somemachine)) - (toFold -> Fold astep abegin adone) - somefold - =- Fold step (Quartet sbegin somemachine abegin (Left' (rt0,somefold))) done - where - step (Quartet sstate machine astate innerfold) i =- let (sstate',oldSplit,newSplits) = sstep sstate i- in- case (oldSplit,newSplits) of- ([],[]) -> - Quartet sstate' machine astate innerfold -- pass innerfold untouched- _ -> - let actualinnerfold = case innerfold of- Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine)- Right' touched -> touched- (machine',astate',innerfold') = - foldl' - step'- (machine,astate,feed actualinnerfold oldSplit) - newSplits- in- Quartet sstate' machine' astate' (Right' innerfold')- - done (Quartet sstate machine astate innerfold) = - let (s,oldSplit,newSplits) = sdone sstate- in- case (oldSplit,newSplits,innerfold) of- ([],[],Left' (_,pristine)) -> - ((s,adone astate), extract pristine)- _ -> - let actualinnerfold = case innerfold of- Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine)- Right' touched -> touched- (_,astate',innerfold') = - foldl' - step'- (machine,astate,feed actualinnerfold oldSplit) - newSplits- (u,finalfold) = extract innerfold'- in - ((s,adone (astep astate' u)),extract finalfold)-- step' (machine_,astate,innerfold_) somesplit = - let (u,resetted,nextmachine) = reset machine_ innerfold_- in (nextmachine,astep astate u,feed resetted somesplit)-- feed = L.fold . duplicated-- reset machine (Fold _ fstate fdone) = - let (u,nextfold) = fdone fstate- ReifiedTransduction' t1 :< nextmachine = machine u- in (u,t1 (duplicated nextfold),nextmachine)--{-| Monadic version of 'groups'. ---}-groupsM :: (Monad m, ToTransducerM m s, ToTransductionsM' m t)- => s a b () -- ^- -> t b c ()- -> TransductionM m a c-groupsM splitter transductions oldfold = - fmap snd (groupsM' splitter transductions unit oldfold)---{-| Monadic version of 'bisect'. ---}-bisectM :: (Monad m, ToTransducerM m s, ToTransductionsM' m h, ToTransductionsM' m t)- => s a b () -- ^- -> h b c ()- -> t b c ()- -> TransductionM m a c-bisectM s t1 t2 = groupsM s (moveHeadM t1 t2)--{-| Monadic version of 'groups''. ---}-groupsM' :: (Monad m, ToTransducerM m s, ToTransductionsM' m t, ToFoldM m f) - => s a b r - -> t b c u -- ^ - -> f u v - -> TransductionM' m a c (r,v) -groupsM' (toTransducerM -> TransducerM sstep sbegin sdone) - (toTransductionsM' -> MooreM (rt0 :< somemachine)) - (toFoldM -> FoldM astep abegin adone) - somefold - =- FoldM step - (do sbegin' <- sbegin- abegin' <- abegin- return (Quartet sbegin' somemachine abegin' (Left' (rt0,somefold))))- done - where- step (Quartet sstate machine astate innerfold) i = do- (sstate',oldSplit, newSplits) <- sstep sstate i - case (oldSplit,newSplits) of - ([],[]) -> - return $! Quartet sstate' machine astate innerfold -- pass innerfold untouched- _ -> do- let actualinnerfold = case innerfold of- Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine)- Right' touched -> touched- innerfold' <- feed actualinnerfold oldSplit- (machine',astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits- return $! Quartet sstate' machine' astate' (Right' innerfold'')-- done (Quartet sstate machine astate innerfold) = do- (s,oldSplit,newSplits) <- sdone sstate- case (oldSplit,newSplits,innerfold) of - ([],[],Left' (_,pristine)) -> do- a <- adone astate- p <- L.foldM pristine []- return ((s,a),p)- _ -> do- let actualinnerfold = case innerfold of- Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine)- Right' touched -> touched- innerfold' <- feed actualinnerfold oldSplit- (_,astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits- (u,finalfold) <- L.foldM innerfold'' []- v <- adone =<< astep astate' u- r <- L.foldM finalfold []- return ((s,v),r)-- step' (machine,astate,innerfold) is = do- (u,innerfold',machine') <- reset machine innerfold - astate' <- astep astate u- innerfold'' <- feed innerfold' is- return $! (machine',astate',innerfold'') -- feed = L.foldM . duplicated-- reset machine (FoldM _ fstate fdone) = do- (u,nextfold) <- fdone =<< fstate - let - ReifiedTransductionM' t1 :< nextmachine = machine u- return (u,t1 (duplicated nextfold),nextmachine)--{-| Summarizes each of the groups demarcated by the 'Transducer' using a- 'Fold'. - - The result value of the 'Transducer' is discarded.-->>> L.fold (folds (chunksOf 3) L.sum L.list) [1..7]-[6,15,7]--}-folds :: (ToTransducer t, ToFold f) - => t a b () -- ^ 'Transducer' working as a splitter.- -> f b c - -> Transduction a c-folds splitter (toFold -> f) = groups splitter (fmap (const ()) (condense f))--{-| Like 'folds', but preserves the return value of the 'Transducer'.-->>> L.fold (folds' (chunksOf 3) L.sum L.list) [1..7]-((),[6,15,7])--}-folds' :: (ToTransducer t, ToFold f) - => t a b s -- ^ 'Transducer' working as a splitter.- -> f b c - -> Transduction' a c s-folds' splitter (toFold -> innerfold) somefold = - fmap (bimap fst id) (groups' splitter innertrans unit somefold)- where- innertrans = reify' $ \x -> fmap ((,) () . snd) (transduce' (condense innerfold) x)--{-| Monadic version of 'folds'. ---}-foldsM :: (Applicative m, Monad m, ToTransducerM m t, ToFoldM m f) - => t a b () -- ^- -> f b c - -> TransductionM m a c-foldsM splitter (toFoldM -> f) = groupsM splitter (fmap (const ()) (condenseM f))--{-| Monadic version of 'folds''. ---}-foldsM' :: (Applicative m,Monad m, ToTransducerM m t, ToFoldM m f) - => t a b s -- ^- -> f b c - -> TransductionM' m a c s-foldsM' splitter (toFoldM -> innerfold) somefold = - fmap (bimap fst id) (groupsM' splitter innertrans unit somefold)- where- innertrans = reifyM' $ \x -> fmap ((,) () . snd) (transduceM' (condenseM innerfold) x)----------------------------------------------------------------------------------{-| 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) (surround [] [0]) L.list) [1..7]-[1,2,0,3,4,0,5,6,0,7,0]--}-chunksOf :: Int -> Transducer a a ()-chunksOf 0 = Transducer (\_ _ -> ((),[],repeat [])) () (error "never happens")-chunksOf groupSize = Transducer step groupSize done - where- step 0 a = (pred groupSize, [], [[a]])- step i a = (pred i, [a], [])- done _ = ((),[],[])--{-| Splits the stream at a given position. -->>> L.fold (bisect (splitAt 2) ignore (reify id) L.list) [1..5]-[3,4,5]---}-splitAt :: Int -> Transducer a a ()-splitAt howmany = - Transducer step (Just howmany) done - where- step Nothing i =- (Nothing,[i],[])- step (Just howmanypending) i - | howmanypending == 0 = - (Nothing,[],[[i]])- | otherwise = - (Just (pred howmanypending),[i],[]) - done = mempty--{-| Similar to `splitAt`, but works with streams of "chunked" data like- bytestrings, texts, vectors, lists of lists... -->>> L.fold (bisect (chunkedSplitAt 7) ignore (reify id) L.list) [[1..5],[6..9]]-[[8,9]]---}-chunkedSplitAt :: SFM.StableFactorialMonoid m => Int -> Transducer m m ()-chunkedSplitAt howmany = - Transducer step (Just howmany) done- where- step Nothing m =- (Nothing,[m],[])- step (Just howmanypending) m- | NM.null m = - (Just howmanypending,[],[])- | howmanypending == 0 = - (Nothing,[],[[m]])- | howmanypending >= SFM.length m =- (Just (howmanypending - SFM.length m),[m],[])- | otherwise =- let (prefix,suffix) = SFM.splitAt howmanypending m- in- (Nothing,[prefix],[[suffix]])- done = mempty--data SplitState = - PreviousSeparator- | PreviousNonSeparator--{-| -->>> L.fold (folds (split (==2)) L.list L.list) [1,2,2,1,1,2,1]-[[1],[],[1,1],[1]]-->>> L.fold (folds (split (==2)) L.list L.list) [2,1,1,2]-[[],[1,1],[]]---}-split :: (a -> Bool) -> Transducer a a ()-split predicate = - Transducer step PreviousNonSeparator done - where- step PreviousNonSeparator i = - if predicate i - then (PreviousSeparator,[],[])- else (PreviousNonSeparator,[i],[])- step PreviousSeparator i = - if predicate i - then (PreviousSeparator,[],[[]])- else (PreviousNonSeparator,[],[[i]])- done PreviousNonSeparator = mempty- done PreviousSeparator = ((),[],[[]])---data BreakWhenState = - BreakConditionEncountered - | BreakConditionPending--{-| -->>> L.fold (bisect (break (>3)) (reify id) ignore L.list) [1..5]-[1,2,3]---}-break :: (a -> Bool) -> Transducer a a ()-break predicate = - Transducer step BreakConditionPending done - where- step BreakConditionPending i = - if predicate i - then (BreakConditionEncountered,[],[[i]])- else (BreakConditionPending,[i],[])- step BreakConditionEncountered i = - (BreakConditionEncountered,[i],[])- done = mempty--{-| Puts the last element of the input stream (if it exists) in a separate- group.-->>> L.fold (bisect (void splitLast) (reify id) ignore L.list) [1..5]-[1,2,3,4]--}-splitLast :: Transducer a a (Maybe a)-splitLast =- Transducer step Nothing done- where- step Nothing i = - (Just i,[],[])- step (Just oldi) i = - (Just i,[oldi],[])- done Nothing = - (Nothing,[],[])- done (Just lasti) = (Just lasti, [], [[lasti]])--{-| Strip a prefix from a stream of "chunked" data, like packed text. -- If the prefix doesn't match, fail with the unmatched part of the prefix and- the input that caused the error.-->>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3..4]]) (L.generalize L.list)) [[1..5],[6..9]]-Right [[5],[6,7,8,9]]-->>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3,77,99]]) (L.generalize L.list)) [[1..5],[6..9]]-Left ([[77,99]],Just [4,5])--}-chunkedStripPrefix :: (CM.LeftGCDMonoid i,SFM.StableFactorialMonoid i,Traversable t,Monad m) - => t i -- ^- -> TransducerM (ExceptT ([i],Maybe i) m) i i ()-chunkedStripPrefix (filter (not . NM.null) . toList -> chunks) = - TransducerM step (return chunks) done- where- step [] i = - return ([],[i],[])- step (x:xs) i = - let (prefix',i',x') = CM.stripCommonPrefix i x - in - if NM.null prefix'- then throwE (x:xs,Just i)- else - if NM.null x' - then step xs i'- else step (x':xs) i'- done [] = - return mempty- done (x:xs) = - throwE (x:xs, Nothing) ----------------------------------------------------------------------------------{- $reexports---}+{-# LANGUAGE ExistentialQuantification, RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} + +{-| This module builds on module "Control.Foldl", adding stateful transducers + and grouping operations. + +>>> L.fold (transduce (surround "[" "]") L.list) "middle" +"[middle]" + +>>> L.fold (folds (chunksOf 2) L.length L.list) "aabbccdd" +[2,2,2,2] + +>>> L.fold (groups (chunksOf 2) (surround "[" "]") L.list) "aabbccdd" +"[aa][bb][cc][dd]" + +-} + +module Control.Foldl.Transduce ( + -- * Transducer types + Transduction + , Transduction' + , Transducer(..) + , ToTransducer(..) + -- ** Monadic transducer types + , TransductionM + , TransductionM' + , TransducerM(..) + , ToTransducerM(..) + -- * Applying transducers + , transduce + , transduce' + , transduceM + , transduceM' + , transduceK + -- * Folding over groups + , folds + , folds' + , foldsM + , foldsM' + -- * Group operations + , ReifiedTransduction' (..) + , reify + , reify' + , Moore(..) + , ToTransductions' (..) + , moveHead + , groups + , bisect + , groups' + -- ** Monadic group operations + , ReifiedTransductionM' (..) + , reifyM + , reifyM' + , MooreM(..) + , ToTransductionsM' (..) + , moveHeadM + , groupsM + , bisectM + , groupsM' + -- * Transducers + , ignore + , surround + , surroundIO + -- * Splitters + , chunksOf + , split + , splitAt + , chunkedSplitAt + , splitLast + , break + , chunkedStripPrefix + -- * Transducer utilities + , foldify + , foldifyM + , condense + , condenseM + , hoistTransducer + -- * Fold utilities + , hoistFold + , unit + , trip + , quiesce + , Fallible(..) + , ToFold(..) + , ToFoldM(..) + -- * Deprecated + -- * Re-exports + -- $reexports + , module Data.Functor.Extend + , module Control.Foldl + , module Control.Comonad.Cofree + ) where + +import Prelude hiding (split,splitAt,break) + +import Data.Functor +import Data.Bifunctor +import Data.Profunctor +import Data.Monoid +import Data.Void +import qualified Data.Monoid.Cancellative as CM +import qualified Data.Monoid.Null as NM +import qualified Data.Monoid.Factorial as SFM +import Data.Functor.Identity +import Data.Functor.Extend +import Data.Foldable (Foldable,foldlM,foldl',toList) +import Data.Traversable +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Comonad +import Control.Comonad.Cofree +import Control.Foldl (Fold(..),FoldM(..),hoists) +import qualified Control.Foldl as L + +{- $setup + +>>> import qualified Control.Foldl as L +>>> import Control.Foldl.Transduce +>>> import Control.Applicative +>>> import qualified Control.Comonad.Cofree as C +>>> import Prelude hiding (split,splitAt,break) + +-} + +------------------------------------------------------------------------------ + +#if !(MIN_VERSION_foldl(1,4,12)) +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 -> return $! FoldM step (return x) done) + {-# INLINABLE duplicated #-} +#endif + +------------------------------------------------------------------------------ + +data Pair a b = Pair !a !b + +data Quartet a b c d = Quartet !a !b !c !d + +fst3 :: (a,b,c) -> a +fst3 (x,_,_) = x + +------------------------------------------------------------------------------ + +{-| A (possibly stateful) transformation on the inputs of a 'Fold'. + + Functions constructed with combinators like 'L.premap' or 'L.handles' from + "Control.Foldl" also typecheck as a 'Transduction'. +-} +type Transduction a b = forall x. Fold b x -> Fold a x + +{-| A more general from of 'Transduction' that adds new information to the + return value of the 'Fold'. + +-} +type Transduction' a b r = forall x. Fold b x -> Fold a (r,x) + +{-| Helper for storing a 'Transduction'' safely on a container. + +-} +newtype ReifiedTransduction' a b r = ReifiedTransduction' { getTransduction' :: Transduction' a b r } + +{-| Convenience constructor, often useful with pure functions like 'id'. + +-} +reify :: Transduction a b -> ReifiedTransduction' a b () +reify t = reify' (fmap (fmap ((,) ())) t) + +reify' :: Transduction' a b r -> ReifiedTransduction' a b r +reify' = ReifiedTransduction' + +{-| A stateful process that transforms a stream of inputs into a stream of + outputs, and may optionally demarcate groups in the stream of outputs. + + Composed of a step function, an initial state, and a extraction function. + + The step function returns a triplet of: + + * The new internal state. + * List of outputs belonging to the last segment detected in the previous step. + * A list of lists of outputs belonging to segments detected in the current + step. If the list is empty, that means no splitting has taken place in the + current step. 'Transducer's that do not perform grouping never return anything + other than @[]@ here. In effect, they treat the whole stream as a single group. + + The extraction function returns the 'Transducer's own result value, along with any + pending output. +-} +data Transducer i o r + = forall x. Transducer (x -> i -> (x,[o],[[o]])) x (x -> (r,[o],[[o]])) + +instance Comonad (Transducer i o) where + extract (Transducer _ begin done) = fst3 (done begin) + {-# INLINABLE extract #-} + + duplicate (Transducer step begin done) = Transducer step begin (\x -> (Transducer step x done,[],[])) + {-# INLINABLE duplicate #-} + +instance Extend (Transducer i o) where + duplicated f = duplicate f + {-# INLINABLE duplicated #-} + +instance Functor (Transducer i o) where + fmap f (Transducer step begin done) = + Transducer + step + begin + ((\(x,xs,xss) -> (f x,xs,xss)) . done) + +instance Bifunctor (Transducer i) where + first f (Transducer step begin done) = + Transducer + (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . step) + begin + ((\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done) + second f w = fmap f w + +{-| Helps converting monadic transducers (over 'Identity') into pure ones. + +-} +class ToTransducer t where + toTransducer :: t i o r -> Transducer i o r + +instance ToTransducer Transducer where + toTransducer = id + +instance ToTransducer (TransducerM Identity) where + toTransducer = _simplify + +class ToFold t where + toFold :: t i r -> Fold i r + +instance ToFold Fold where + toFold = id + +instance ToFold (FoldM Identity) where + toFold = L.simplify + +{-| Like 'Transduction', but works on monadic 'Fold's. + +-} +type TransductionM m a b = forall x. Monad m => FoldM m b x -> FoldM m a x + +{-| Like 'Transduction'', but works on monadic 'Fold's. + +-} +type TransductionM' m a b r = forall x. FoldM m b x -> FoldM m a (r,x) + +{-| Helper for storing a 'TransductionM'' safely on a container. + +-} +newtype ReifiedTransductionM' m a b r = ReifiedTransductionM' { getTransductionM' :: TransductionM' m a b r } + +{-| Monadic version of 'reify'. + +-} +reifyM :: Monad m => TransductionM m a b -> ReifiedTransductionM' m a b () +reifyM t = reifyM' (fmap (fmap ((,) ())) t) + +{-| Monadic version of 'reifyM'. + +-} +reifyM' :: TransductionM' m a b r -> ReifiedTransductionM' m a b r +reifyM' = ReifiedTransductionM' + +{-| Like 'Transducer', but monadic. + +-} +data TransducerM m i o r + = forall x. TransducerM (x -> i -> m (x,[o],[[o]])) (m x) (x -> m (r,[o],[[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,oss) <- done x + let r' = f r + return $! (r' `seq` (r',os,oss)) + +instance (Functor m, Monad m) => Bifunctor (TransducerM m i) where + first f (TransducerM step begin done) = + TransducerM + (fmap (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss))) . step) + begin + (fmap (\(x,xs,xss) -> (x,map f xs, map (map f) xss)) . done) + second f w = fmap f w + +instance Monad m => Extend (TransducerM m i o) where + duplicated (TransducerM step begin done) = + TransducerM step begin (\x -> return $! (TransducerM step (return x) done,[],[])) + {-# INLINABLE duplicated #-} + + +{-| Helps converting pure transducers into monadic ones. + +-} +class ToTransducerM m t where + toTransducerM :: t i o r -> TransducerM m i o r + +-- http://chrisdone.com/posts/haskell-constraint-trick +instance (m ~ m') => ToTransducerM m (TransducerM m') where + toTransducerM = id + +instance Monad m => ToTransducerM m Transducer where + toTransducerM = _generalize + +class ToFoldM m t where + toFoldM :: t i r -> FoldM m i r + +instance (m ~ m') => ToFoldM m (FoldM m') where + toFoldM = id + +instance Monad m => ToFoldM m Fold where + toFoldM = L.generalize + + +{-| Apply a 'Transducer' to a 'Fold', discarding the return value of the + 'Transducer'. + +>>> L.fold (transduce (Transducer (\_ i -> ((),[i],[])) () (\_ -> ((),[],[]))) L.list) [1..7] +[1,2,3,4,5,6,7] +-} +transduce :: ToTransducer t => t i o () -> Transduction i o +transduce t = fmap snd . (transduce' t) + +{-| Generalized version of 'transduce' that preserves 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' :: ToTransducer t => t i o s -> Transduction' i o s +transduce' (toTransducer -> Transducer wstep wstate wdone) (Fold fstep fstate fdone) = + Fold step (Pair wstate fstate) done + where + step (Pair ws fs) i = + let (ws',os,oss) = wstep ws i + in + Pair ws' (foldl' fstep fs (os ++ mconcat oss)) + done (Pair ws fs) = + let (wr,os,oss) = wdone ws + in + (,) wr (fdone (foldl' fstep fs (os ++ mconcat oss))) + + +{-| Like 'transduce', but works on monadic 'Fold's. + +-} +transduceM :: (Monad m, ToTransducerM m t) => t i o () -> TransductionM m i o +transduceM t = fmap snd . (transduceM' t) + +{-| Like 'transduce'', but works on monadic 'Fold's. + +-} +transduceM' :: (Monad m, ToTransducerM m t) => t i o s -> TransductionM' m i o s +transduceM' (toTransducerM -> TransducerM wstep wstate wdone) (FoldM fstep fstate fdone) = + FoldM step (liftM2 Pair wstate fstate) done + where + step (Pair ws fs) i = do + (ws',os,oss) <- wstep ws i + fs' <- foldlM fstep fs (os ++ mconcat oss) + return $! Pair ws' fs' + done (Pair ws fs) = do + (wr,os,oss) <- wdone ws + fr <- fdone =<< foldlM fstep fs (os ++ mconcat oss) + return $! (,) wr fr + +{-| Transduce with a Kleisli arrow that returns a list. + +-} +transduceK :: (Monad m) => (i -> m [o]) -> TransductionM m i o +transduceK k = transduceM (TransducerM step (return ()) (\_ -> return ((),[],[]))) + where + step _ i = liftM (\os -> ((),os,[])) (k i) + + +------------------------------------------------------------------------------ + +{-| Ignore all the inputs coming into the fold. + + Polymorphic in both inputs and outputs. + +-} +ignore :: Transducer a b () +ignore = + Transducer step () done + where + step _ _ = + ((),[],[]) + done = + const ((),[],[]) + +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" + + Used as a splitter, it puts the prefix, the original stream and + the suffix in separate groups: + +>>> L.fold (groups (surround "prefix" "suffix") (surround "[" "]") L.list) "middle" +"[prefix][middle][suffix]" + +-} +surround :: (Traversable p, Traversable 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 :: (Traversable p, Traversable s, Functor m, 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 ((), ps, [[],ss]) + done PrefixAdded = do + ss <- fmap toList suffixa + return ((), [], [ss]) + +------------------------------------------------------------------------------ + +{-| Generalize a 'Transducer' to a 'TransducerM'. + +-} +_generalize :: Monad m => Transducer i o s -> TransducerM m i o s +_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 s -> Transducer i o s +_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 s -> Fold i s +foldify (Transducer step begin done) = + Fold (\x i -> fst3 (step x i)) begin (\x -> fst3 (done x)) + +{-| Monadic version of 'foldify'. + +-} +foldifyM :: Functor m => TransducerM m i o s -> FoldM m i s +foldifyM (TransducerM step begin done) = + FoldM (\x i -> fmap fst3 (step x i)) begin (\x -> fmap fst3 (done x)) + +{-| Transforms a 'Fold' into a 'Transducer' that sends the return value of the + 'Fold' downstream when upstream closes. + +-} +condense :: Fold a r -> Transducer a r r +condense (Fold fstep fstate fdone) = + (Transducer wstep fstate wdone) + where + wstep = \fstate' i -> (fstep fstate' i,[],[]) + wdone = \fstate' -> (\r -> (r,[r],[])) (fdone fstate') + +{-| Monadic version of 'condense'. + +-} +condenseM :: Applicative m => FoldM m a r -> TransducerM m a r r +condenseM (FoldM fstep fstate fdone) = + (TransducerM wstep fstate wdone) + where + wstep = \fstate' i -> fmap (\s -> (s,[],[])) (fstep fstate' i) + wdone = \fstate' -> fmap (\r -> (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 s -> TransducerM n i o s +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'. + + Another name for 'Control.Foldl.hoists'. +-} +hoistFold :: Monad m => (forall a. m a -> n a) -> FoldM m i r -> FoldM n i r +hoistFold = Control.Foldl.hoists + +{-| Turn a 'FoldM' that fails abruptly into one that encodes the error into + its return value. + + Can be useful when combining fallible 'FoldM's with non-fallible ones. + +>>> L.foldM (quiesce (FoldM (\_ _-> throwE ()) (return ()) (\_ -> throwE ()))) [1..7] +Left () +-} +quiesce :: Monad m => FoldM (ExceptT e m) a r -> FoldM m a (Either e r) +quiesce (FoldM step initial done) = + FoldM step' (runExceptT initial) done' + where + step' x i = do + case x of + Left _ -> return x + Right notyetfail -> runExceptT (step notyetfail i) + done' x = do + case x of + Left e -> return (Left e) + Right notyetfail -> do + result <- runExceptT (done notyetfail) + case result of + Left e -> return (Left e) + Right r -> return (Right r) + +newtype Fallible m r i e = Fallible { getFallible :: FoldM (ExceptT e m) i r } + +bindFallible :: (Functor m,Monad m) => Fallible m r i e -> (e -> Fallible m r i e') -> Fallible m r i e' +bindFallible (Fallible (FoldM step initial done)) k = + Fallible (FoldM step' (lift (runExceptT (withExceptT (getFallible . k) initial))) done') + where + step' x i = ExceptT (case x of + Left ffold -> do + rx <- runExceptT (L.foldM (duplicated ffold) [i]) + case rx of + Left e' -> return (Left e') -- true failure + Right ffold' -> return (Right (Left ffold')) + Right notyetfail -> do + x' <- runExceptT (step notyetfail i) + case x' of + Left e -> do + return (Right (Left ((getFallible . k) e))) + Right x'' -> return (Right (Right x''))) + done' x = ExceptT (case x of + Left ffold -> do + rx <- runExceptT (L.foldM ffold []) + case rx of + Left e' -> return (Left e') -- true failure + Right r -> return (Right r) + Right notyetfail -> do + x' <- runExceptT (done notyetfail) + case x' of + Left e -> do + runExceptT (done' (Left (getFallible (k e)))) + Right x'' -> return (Right x'')) + +instance (Functor m, Monad m) => Functor (Fallible m r i) where + fmap g (Fallible fallible) = + Fallible (hoistFold (withExceptT g) fallible) + + +{-| 'pure' creates a 'Fallible' that starts in a failed state. + +-} +instance (Functor m,Monad m) => Applicative (Fallible m r i) where + pure e = Fallible (FoldM (\_ _ -> throwE e) (throwE e) (\_ -> throwE e)) + + u <*> v = u >>= \f -> fmap f v + +instance (Functor m, Monad m) => Profunctor (Fallible m r) where + lmap f (Fallible fallible) = + Fallible (L.premapM (return . f) fallible) + + rmap g (Fallible fallible) = + Fallible (hoistFold (withExceptT g) fallible) + +{-| Fail immediately when an input comes in the wrong branch. + +-} +instance (Functor m,Monad m,Monoid r) => Choice (Fallible m r) where + left' (Fallible fallible) = + Fallible (liftA2 mappend (hoistFold (withExceptT Left) (L.handlesM _Left fallible)) (hoistFold (withExceptT Right) (L.handlesM _Right (trip $> mempty)))) + +_Left :: Applicative f => (a -> f a) -> Either a b -> f (Either a b) +_Left f e = case e of + Right b -> pure (Right b) + Left a -> fmap Left (f a) + +_Right :: Applicative f => (b -> f b) -> Either a b -> f (Either a b) +_Right f e = case e of + Left b -> pure (Left b) + Right a -> fmap Right (f a) + +{-| '>>=' continues folding after an error using a 'Fallible' constructed from the error. + +-} +instance (Functor m,Monad m) => Monad (Fallible m r i) where + (>>=) = bindFallible + return = pure + +{-| The "do-nothing" fold. + +-} +unit :: Fold a () +unit = pure () + +{-| A fold that fails if it receives any input at all. The received input is + used as the error. + +-} +trip :: Monad m => FoldM (ExceptT a m) a () +trip = FoldM (\_ x -> throwE x) (return ()) (\_ -> return mempty) + +------------------------------------------------------------------------------ + +{-| An unending machine that eats @u@ values and returns + 'ReifiedTransduction''s whose result type is also @u@. + +-} +newtype Moore a b u = Moore { getMoore :: Cofree ((->) u) (ReifiedTransduction' a b u) } + +{-| Monadic version of 'Moore'. + +-} +newtype MooreM m a b u = MooreM { getMooreM :: Cofree ((->) u) (ReifiedTransductionM' m a b u) } + +{-| Prepend the head of the first argument to the second argument. + +-} +moveHead :: (ToTransductions' h,ToTransductions' t) => h a b u -> t a b u -> Moore a b u +moveHead (toTransductions' -> Moore (theHead :< _)) (toTransductions' -> Moore theTail) = Moore (theHead :< const theTail) + +{-| Monadic version of 'moveHead'. + +-} +moveHeadM :: (Monad m, ToTransductionsM' m h, ToTransductionsM' m t) => h a b u -> t a b u -> MooreM m a b u +moveHeadM (toTransductionsM' -> MooreM (theHead :< _)) (toTransductionsM' -> MooreM theTail) = MooreM (theHead :< const theTail) + +{-| Helper for obtaining infinite sequences of 'Transduction''s from suitable + types (in order to avoid explicit conversions). + +-} +class ToTransductions' t where + toTransductions' :: t a b u -> Moore a b u + +instance ToTransductions' Moore where + toTransductions' = id + +instance ToTransductions' Transducer where + toTransductions' t = toTransductions' (reify' (transduce' t)) + +instance ToTransductions' ReifiedTransduction' where + toTransductions' = Moore . coiter const + +{-| Monadic version of 'ToTransductions''. + +-} +class Monad m => ToTransductionsM' m t where + toTransductionsM' :: t a b u -> MooreM m a b u + +instance (m ~ m', Monad m') => ToTransductionsM' m (MooreM m') where + toTransductionsM' = id + +instance (m ~ m', Monad m') => ToTransductionsM' m (TransducerM m') where + toTransductionsM' t = toTransductionsM' (reifyM' (transduceM' t)) + +instance Monad m => ToTransductionsM' m Transducer where + toTransductionsM' (toTransducerM -> t) = toTransductionsM' (reifyM' (transduceM' t)) + +instance (m ~ m', Monad m') => ToTransductionsM' m (ReifiedTransductionM' m') where + toTransductionsM' = MooreM . coiter const + +{-| Processes each of the groups demarcated by a 'Transducer' using + a 'Transduction' taken from an unending supply, + returning a 'Transduction' what works over the undivided stream of inputs. + + The return value of the 'Transducer' is discarded. + +>>> L.fold (groups (chunksOf 2) (surround "<" ">") L.list) "aabbccdd" +"<aa><bb><cc><dd>" + +>>> :{ + let transductions = Moore (C.unfold (\i -> + (reify (transduce (surround (show i) [])), \_ -> succ i)) 0) + in L.fold (groups (chunksOf 2) transductions L.list) "aabbccdd" + :} +"0aa1bb2cc3dd" +-} +groups :: (ToTransducer s, ToTransductions' t) + => s a b () -- ^ 'Transducer' working as a splitter. + -> t b c () -- ^ infinite list of transductions + -> Transduction a c +groups splitter transductions oldfold = + fmap snd (groups' splitter transductions unit oldfold) + +{-| Use a different 'Transduction' for the first detected group. + +>>> :{ + let drop n = bisect (splitAt n) ignore (reify id) + in L.fold (drop 2 L.list) "aabbccdd" + :} +"bbccdd" +-} +bisect :: (ToTransducer s, ToTransductions' h, ToTransductions' t) + => s a b () -- ^ 'Transducer' working as a splitter. + -> h b c () -- ^ Machine to process the first group + -> t b c () -- ^ Machine to process the second and subsequent groups + -> Transduction a c +bisect sp t1 t2 = groups sp (moveHead t1 t2) + +data StrictSum a b = Left' !a | Right' !b + +{-| Generalized version of 'groups' that preserves the return value of the + 'Transducer'. + + A summary value for each group is also calculated. These values are + aggregated for the whole stream, with the help of an auxiliary 'Fold'. + + +>>> :{ + let transductions = + reify' (\f -> transduce (surround "<" ">") ((,) <$> L.list <*> f)) + in L.fold (groups' (chunksOf 2) transductions L.list L.list) "aabbccdd" + :} +(((),["<aa>","<bb>","<cc>","<dd>"]),"<aa><bb><cc><dd>") +-} +groups' :: (ToTransducer s, ToTransductions' t, ToFold f) + => s a b r -- ^ 'Transducer' working as a splitter. + -> t b c u -- ^ machine that eats @u@ values and spits transductions + -> f u v -- ^ auxiliary 'Fold' that aggregates the @u@ values produced for each group + -> Transduction' a c (r,v) +groups' (toTransducer -> Transducer sstep sbegin sdone) + (toTransductions' -> Moore (rt0 :< somemachine)) + (toFold -> Fold astep abegin adone) + somefold + = + Fold step (Quartet sbegin somemachine abegin (Left' (rt0,somefold))) done + where + step (Quartet sstate machine astate innerfold) i = + let (sstate',oldSplit,newSplits) = sstep sstate i + in + case (oldSplit,newSplits) of + ([],[]) -> + Quartet sstate' machine astate innerfold -- pass innerfold untouched + _ -> + let actualinnerfold = case innerfold of + Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine) + Right' touched -> touched + (machine',astate',innerfold') = + foldl' + step' + (machine,astate,feed actualinnerfold oldSplit) + newSplits + in + Quartet sstate' machine' astate' (Right' innerfold') + + done (Quartet sstate machine astate innerfold) = + let (s,oldSplit,newSplits) = sdone sstate + in + case (oldSplit,newSplits,innerfold) of + ([],[],Left' (_,pristine)) -> + ((s,adone astate), extract pristine) + _ -> + let actualinnerfold = case innerfold of + Left' (ReifiedTransduction' t0,pristine) -> t0 (duplicated pristine) + Right' touched -> touched + (_,astate',innerfold') = + foldl' + step' + (machine,astate,feed actualinnerfold oldSplit) + newSplits + (u,finalfold) = extract innerfold' + in + ((s,adone (astep astate' u)),extract finalfold) + + step' (machine_,astate,innerfold_) somesplit = + let (u,resetted,nextmachine) = reset machine_ innerfold_ + in (nextmachine,astep astate u,feed resetted somesplit) + + feed = L.fold . duplicated + + reset machine (Fold _ fstate fdone) = + let (u,nextfold) = fdone fstate + ReifiedTransduction' t1 :< nextmachine = machine u + in (u,t1 (duplicated nextfold),nextmachine) + +{-| Monadic version of 'groups'. + +-} +groupsM :: (Monad m, ToTransducerM m s, ToTransductionsM' m t) + => s a b () -- ^ + -> t b c () + -> TransductionM m a c +groupsM splitter transductions oldfold = + fmap snd (groupsM' splitter transductions unit oldfold) + + +{-| Monadic version of 'bisect'. + +-} +bisectM :: (Monad m, ToTransducerM m s, ToTransductionsM' m h, ToTransductionsM' m t) + => s a b () -- ^ + -> h b c () + -> t b c () + -> TransductionM m a c +bisectM s t1 t2 = groupsM s (moveHeadM t1 t2) + +{-| Monadic version of 'groups''. + +-} +groupsM' :: (Monad m, ToTransducerM m s, ToTransductionsM' m t, ToFoldM m f) + => s a b r + -> t b c u -- ^ + -> f u v + -> TransductionM' m a c (r,v) +groupsM' (toTransducerM -> TransducerM sstep sbegin sdone) + (toTransductionsM' -> MooreM (rt0 :< somemachine)) + (toFoldM -> FoldM astep abegin adone) + somefold + = + FoldM step + (do sbegin' <- sbegin + abegin' <- abegin + return (Quartet sbegin' somemachine abegin' (Left' (rt0,somefold)))) + done + where + step (Quartet sstate machine astate innerfold) i = do + (sstate',oldSplit, newSplits) <- sstep sstate i + case (oldSplit,newSplits) of + ([],[]) -> + return $! Quartet sstate' machine astate innerfold -- pass innerfold untouched + _ -> do + let actualinnerfold = case innerfold of + Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine) + Right' touched -> touched + innerfold' <- feed actualinnerfold oldSplit + (machine',astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits + return $! Quartet sstate' machine' astate' (Right' innerfold'') + + done (Quartet sstate machine astate innerfold) = do + (s,oldSplit,newSplits) <- sdone sstate + case (oldSplit,newSplits,innerfold) of + ([],[],Left' (_,pristine)) -> do + a <- adone astate + p <- L.foldM pristine [] + return ((s,a),p) + _ -> do + let actualinnerfold = case innerfold of + Left' (ReifiedTransductionM' t0,pristine) -> t0 (duplicated pristine) + Right' touched -> touched + innerfold' <- feed actualinnerfold oldSplit + (_,astate',innerfold'') <- foldlM step' (machine,astate,innerfold') newSplits + (u,finalfold) <- L.foldM innerfold'' [] + v <- adone =<< astep astate' u + r <- L.foldM finalfold [] + return ((s,v),r) + + step' (machine,astate,innerfold) is = do + (u,innerfold',machine') <- reset machine innerfold + astate' <- astep astate u + innerfold'' <- feed innerfold' is + return $! (machine',astate',innerfold'') + + feed = L.foldM . duplicated + + reset machine (FoldM _ fstate fdone) = do + (u,nextfold) <- fdone =<< fstate + let + ReifiedTransductionM' t1 :< nextmachine = machine u + return (u,t1 (duplicated nextfold),nextmachine) + +{-| Summarizes each of the groups demarcated by the 'Transducer' using a + 'Fold'. + + The result value of the 'Transducer' is discarded. + +>>> L.fold (folds (chunksOf 3) L.sum L.list) [1..7] +[6,15,7] +-} +folds :: (ToTransducer t, ToFold f) + => t a b () -- ^ 'Transducer' working as a splitter. + -> f b c + -> Transduction a c +folds splitter (toFold -> f) = groups splitter (fmap (const ()) (condense f)) + +{-| Like 'folds', but preserves the return value of the 'Transducer'. + +>>> L.fold (folds' (chunksOf 3) L.sum L.list) [1..7] +((),[6,15,7]) +-} +folds' :: (ToTransducer t, ToFold f) + => t a b s -- ^ 'Transducer' working as a splitter. + -> f b c + -> Transduction' a c s +folds' splitter (toFold -> innerfold) somefold = + fmap (bimap fst id) (groups' splitter innertrans unit somefold) + where + innertrans = reify' $ \x -> fmap ((,) () . snd) (transduce' (condense innerfold) x) + +{-| Monadic version of 'folds'. + +-} +foldsM :: (Applicative m, Monad m, ToTransducerM m t, ToFoldM m f) + => t a b () -- ^ + -> f b c + -> TransductionM m a c +foldsM splitter (toFoldM -> f) = groupsM splitter (fmap (const ()) (condenseM f)) + +{-| Monadic version of 'folds''. + +-} +foldsM' :: (Applicative m,Monad m, ToTransducerM m t, ToFoldM m f) + => t a b s -- ^ + -> f b c + -> TransductionM' m a c s +foldsM' splitter (toFoldM -> innerfold) somefold = + fmap (bimap fst id) (groupsM' splitter innertrans unit somefold) + where + innertrans = reifyM' $ \x -> fmap ((,) () . snd) (transduceM' (condenseM innerfold) x) + +------------------------------------------------------------------------------ + +{-| 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) (surround [] [0]) L.list) [1..7] +[1,2,0,3,4,0,5,6,0,7,0] +-} +chunksOf :: Int -> Transducer a a () +chunksOf 0 = Transducer (\_ _ -> ((),[],repeat [])) () (error "never happens") +chunksOf groupSize = Transducer step groupSize done + where + step 0 a = (pred groupSize, [], [[a]]) + step i a = (pred i, [a], []) + done _ = ((),[],[]) + +{-| Splits the stream at a given position. + +>>> L.fold (bisect (splitAt 2) ignore (reify id) L.list) [1..5] +[3,4,5] + +-} +splitAt :: Int -> Transducer a a () +splitAt howmany = + Transducer step (Just howmany) done + where + step Nothing i = + (Nothing,[i],[]) + step (Just howmanypending) i + | howmanypending == 0 = + (Nothing,[],[[i]]) + | otherwise = + (Just (pred howmanypending),[i],[]) + done = mempty + +{-| Similar to `splitAt`, but works with streams of "chunked" data like + bytestrings, texts, vectors, lists of lists... + +>>> L.fold (bisect (chunkedSplitAt 7) ignore (reify id) L.list) [[1..5],[6..9]] +[[8,9]] + +-} +chunkedSplitAt :: SFM.StableFactorialMonoid m => Int -> Transducer m m () +chunkedSplitAt howmany = + Transducer step (Just howmany) done + where + step Nothing m = + (Nothing,[m],[]) + step (Just howmanypending) m + | NM.null m = + (Just howmanypending,[],[]) + | howmanypending == 0 = + (Nothing,[],[[m]]) + | howmanypending >= SFM.length m = + (Just (howmanypending - SFM.length m),[m],[]) + | otherwise = + let (prefix,suffix) = SFM.splitAt howmanypending m + in + (Nothing,[prefix],[[suffix]]) + done = mempty + +data SplitState = + PreviousSeparator + | PreviousNonSeparator + +{-| + +>>> L.fold (folds (split (==2)) L.list L.list) [1,2,2,1,1,2,1] +[[1],[],[1,1],[1]] + +>>> L.fold (folds (split (==2)) L.list L.list) [2,1,1,2] +[[],[1,1],[]] + +-} +split :: (a -> Bool) -> Transducer a a () +split predicate = + Transducer step PreviousNonSeparator done + where + step PreviousNonSeparator i = + if predicate i + then (PreviousSeparator,[],[]) + else (PreviousNonSeparator,[i],[]) + step PreviousSeparator i = + if predicate i + then (PreviousSeparator,[],[[]]) + else (PreviousNonSeparator,[],[[i]]) + done PreviousNonSeparator = mempty + done PreviousSeparator = ((),[],[[]]) + + +data BreakWhenState = + BreakConditionEncountered + | BreakConditionPending + +{-| + +>>> L.fold (bisect (break (>3)) (reify id) ignore L.list) [1..5] +[1,2,3] + +-} +break :: (a -> Bool) -> Transducer a a () +break predicate = + Transducer step BreakConditionPending done + where + step BreakConditionPending i = + if predicate i + then (BreakConditionEncountered,[],[[i]]) + else (BreakConditionPending,[i],[]) + step BreakConditionEncountered i = + (BreakConditionEncountered,[i],[]) + done = mempty + +{-| Puts the last element of the input stream (if it exists) in a separate + group. + +>>> L.fold (bisect (void splitLast) (reify id) ignore L.list) [1..5] +[1,2,3,4] +-} +splitLast :: Transducer a a (Maybe a) +splitLast = + Transducer step Nothing done + where + step Nothing i = + (Just i,[],[]) + step (Just oldi) i = + (Just i,[oldi],[]) + done Nothing = + (Nothing,[],[]) + done (Just lasti) = (Just lasti, [], [[lasti]]) + +{-| Strip a prefix from a stream of "chunked" data, like packed text. + + If the prefix doesn't match, fail with the unmatched part of the prefix and + the input that caused the error. + +>>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3..4]]) (L.generalize L.list)) [[1..5],[6..9]] +Right [[5],[6,7,8,9]] + +>>> runExceptT $ L.foldM (transduceM (chunkedStripPrefix [[1..2],[3,77,99]]) (L.generalize L.list)) [[1..5],[6..9]] +Left ([[77,99]],Just [4,5]) +-} +chunkedStripPrefix :: (CM.LeftGCDMonoid i,SFM.StableFactorialMonoid i,Traversable t,Monad m) + => t i -- ^ + -> TransducerM (ExceptT ([i],Maybe i) m) i i () +chunkedStripPrefix (filter (not . NM.null) . toList -> chunks) = + TransducerM step (return chunks) done + where + step [] i = + return ([],[i],[]) + step (x:xs) i = + let (prefix',i',x') = CM.stripCommonPrefix i x + in + if NM.null prefix' + then throwE (x:xs,Just i) + else + if NM.null x' + then step xs i' + else step (x':xs) i' + done [] = + return mempty + done (x:xs) = + throwE (x:xs, Nothing) + +------------------------------------------------------------------------------ + +{- $reexports + +-}
src/Control/Foldl/Transduce/ByteString.hs view
@@ -1,88 +1,88 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- |------ Pour handles into folds,--- write to handles using folds. -module Control.Foldl.Transduce.ByteString (- -- * Reading from handles- drainHandle- , ChunkSize- , chunkSize- , chunkSizeDefault- -- * Writing to handles- , toHandle- , toHandleBuilder - ) where--import qualified Control.Foldl as L-import Control.Foldl.Transduce -import qualified Data.ByteString as B-import qualified Data.ByteString.Builder as B-import Control.Monad.IO.Class-import System.IO-import Data.ByteString.Lazy.Internal (defaultChunkSize)--{-| Feed a fold with bytes read from a 'Handle'.---}-drainHandle - :: (MonadIO m,ToFoldM m f) - => f B.ByteString r - -> ChunkSize - -> Handle - -> m r -drainHandle f (ChunkSize csize) h = driveHandle f csize h--{-| Maximum chunk size ---}-newtype ChunkSize = ChunkSize Int deriving (Show,Eq,Ord,Num)--chunkSize :: Int -> ChunkSize-chunkSize = ChunkSize--chunkSizeDefault :: ChunkSize-chunkSizeDefault = chunkSize defaultChunkSize--driveHandle :: (MonadIO m,ToFoldM m f) - => f B.ByteString r - -> Int -- ^ max chunk size- -> Handle - -> m r -driveHandle (toFoldM -> f) chunkSize handle = - L.impurely consumeFunc f (B.hGetSome handle chunkSize,hIsEOF handle)- where- -- adapted from foldM in Pipes.Prelude- consumeFunc step begin done (readChunk,checkEOF) = do- x0 <- begin- loop x0- where- loop x = do- atEOF <- liftIO checkEOF- if atEOF - then done x - else do- chunk <- liftIO readChunk- x' <- step x chunk- loop $! x'---toHandle :: (MonadIO m) => Handle -> L.FoldM m B.ByteString ()-toHandle handle = - L.FoldM - (\_ b -> liftIO (B.hPut handle b)) - (return ()) - (\_ -> return ())---toHandleBuilder :: (MonadIO m) => Handle -> L.FoldM m B.Builder ()-toHandleBuilder handle = - L.FoldM- (\_ b -> liftIO (B.hPutBuilder handle b)) - (return ()) - (\_ -> return ())--+{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- +-- Pour handles into folds, +-- write to handles using folds. +module Control.Foldl.Transduce.ByteString ( + -- * Reading from handles + drainHandle + , ChunkSize + , chunkSize + , chunkSizeDefault + -- * Writing to handles + , toHandle + , toHandleBuilder + ) where + +import qualified Control.Foldl as L +import Control.Foldl.Transduce +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as B +import Control.Monad.IO.Class +import System.IO +import Data.ByteString.Lazy.Internal (defaultChunkSize) + +{-| Feed a fold with bytes read from a 'Handle'. + +-} +drainHandle + :: (MonadIO m,ToFoldM m f) + => f B.ByteString r + -> ChunkSize + -> Handle + -> m r +drainHandle f (ChunkSize csize) h = driveHandle f csize h + +{-| Maximum chunk size + +-} +newtype ChunkSize = ChunkSize Int deriving (Show,Eq,Ord,Num) + +chunkSize :: Int -> ChunkSize +chunkSize = ChunkSize + +chunkSizeDefault :: ChunkSize +chunkSizeDefault = chunkSize defaultChunkSize + +driveHandle :: (MonadIO m,ToFoldM m f) + => f B.ByteString r + -> Int -- ^ max chunk size + -> Handle + -> m r +driveHandle (toFoldM -> f) chunkSize handle = + L.impurely consumeFunc f (B.hGetSome handle chunkSize,hIsEOF handle) + where + -- adapted from foldM in Pipes.Prelude + consumeFunc step begin done (readChunk,checkEOF) = do + x0 <- begin + loop x0 + where + loop x = do + atEOF <- liftIO checkEOF + if atEOF + then done x + else do + chunk <- liftIO readChunk + x' <- step x chunk + loop $! x' + + +toHandle :: (MonadIO m) => Handle -> L.FoldM m B.ByteString () +toHandle handle = + L.FoldM + (\_ b -> liftIO (B.hPut handle b)) + (return ()) + (\_ -> return ()) + + +toHandleBuilder :: (MonadIO m) => Handle -> L.FoldM m B.Builder () +toHandleBuilder handle = + L.FoldM + (\_ b -> liftIO (B.hPutBuilder handle b)) + (return ()) + (\_ -> return ()) + +
src/Control/Foldl/Transduce/Text.hs view
@@ -1,536 +1,536 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ViewPatterns #-}---- |------ 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- , words- , lines- , paragraphs- , sections- -- * Textual- -- $textual- , textualSplit- , textualBreak- ) where--import Prelude hiding (lines,words)-import Data.Char-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 qualified Data.List-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NonEmpty--{- $setup-->>> :set -XFlexibleContexts->>> import Data.String hiding (lines,words)->>> import Data.Text (Text)->>> import Control.Applicative->>> import Control.Monad.Trans.Except->>> import qualified Control.Foldl as L->>> import Control.Foldl.Transduce---}--data Pair a b = Pair !a !b--{-| 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 '\xc3': 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 (return (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 (return . 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 '\xc3': 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 of text into lines, removing the newlines.-->>> L.fold (L.groups lines (surround [T.pack "x"] []) L.list) (map T.pack ["line 1\n line 2\n"])-["x","line 1","x"," line 2"]-->>> L.fold (L.groups lines newline L.list) (map T.pack ["line 1\n line 2\n"])-["line 1","\n"," line 2","\n"]-- Used with 'L.transduce', it simply removes newlines:-->>> L.fold (L.transduce lines L.list) (map T.pack ["line 1\n line 2\n"])-["line 1"," line 2"]--}-lines :: L.Transducer T.Text T.Text ()-lines = L.Transducer step False done - where- step previousnl txt =- if Data.Text.null txt- then - (previousnl,[],[])- else- let- lastc = Data.Text.last txt == '\n'- txts = T.lines txt- in- case (previousnl,txts) of- (_,[]) -> error "never happens"- (True,_) -> (lastc, [], map pure txts)- (False,t:ts) -> (lastc, [t], map pure ts)-- done _ = ((),[],[])---data WordsState = - NoLastChar- | LastCharSpace- | LastCharNotSpace--{-| Splits a stream of text into words, removing whitespace.-->>> L.fold (folds words L.list L.list) (map T.pack [" a","aa ", "bb c","cc dd ","ee f","f"])-[["a","aa"],["bb"],["c","cc"],["dd"],["ee"],["f","f"]]-- Used with 'L.transduce', it simply removes all whitespace:-->>> L.fold (L.transduce words L.list) (map T.pack [" a","aa ", "bb c","cc dd ","ee f","f"])-["a","aa","bb","c","cc","dd","ee","f","f"]--}-words :: L.Transducer T.Text T.Text ()-words = L.Transducer step NoLastChar done - where- step tstate txt - | Data.Text.null txt = (tstate,[],[])- | blank txt = - case tstate of- NoLastChar -> (NoLastChar,[],[])- _ -> (LastCharSpace,[],[])- | otherwise = - let nextstate = - if isSpace (T.last txt) - then LastCharSpace - else LastCharNotSpace- (oldgroup,newgroups) = case (tstate, T.words txt) of- (NoLastChar,w:ws) -> - ([w],map pure ws)- (LastCharSpace,ws) -> - ([],map pure ws)- (LastCharNotSpace,w:ws) -> - if isSpace (T.head txt)- then ([],map pure (w:ws))- else ([w],map pure ws)- (_,[]) -> error "never happens, txt not blank"- in (nextstate,oldgroup,newgroups)- done _ = ((),[],[])---data ParagraphsState = - SkippingAfterStreamStart- | SkippingAfterNewline- | SkippingAfterBlankLine- | ContinuingNonemptyLine--{-| Splits a stream of text into paragraphs, removing empty lines and trimming- newspace from the start of each line.-->>> map mconcat (L.fold (folds paragraphs L.list L.list) (map T.pack [" \n aaa","\naa ", " \n\nbb\n"]))-["aaa\naa \n","bb\n"]-- Used with 'L.transduce', it removes empty lines and trims newspace from the- start of each line.--}-paragraphs :: L.Transducer T.Text T.Text ()-paragraphs = L.Transducer step SkippingAfterStreamStart done - where- step tstate txt- | Data.Text.null txt = - (tstate,[],[])- | otherwise = - let (initlines,lastline) = splittedLines txt- (tstate', outputsreversed) =- advanceLast- (foldl' - advance- (tstate,pure [])- initlines)- lastline - (xs :| xss) = fmap reverse (NonEmpty.reverse outputsreversed)- in (tstate',xs,xss)- done _ = - ((),[],[])- splittedLines :: T.Text -> ([T.Text],T.Text)- splittedLines nonEmptyChunk = - let splitted = - Data.Text.lines nonEmptyChunk - ++- if T.last nonEmptyChunk == '\n' then [mempty] else mempty- in (init splitted, last splitted) -- unsafe with empty lists!!!- advance - :: (ParagraphsState, NonEmpty [T.Text]) - -> T.Text - -> (ParagraphsState, NonEmpty [T.Text])- advance (s,outputs) i = - case (s, blank i) of- (SkippingAfterStreamStart, True) -> - (,) - SkippingAfterStreamStart - outputs- (SkippingAfterStreamStart, False) -> - (,)- SkippingAfterNewline- (continue ["\n",T.stripStart i] outputs) - (SkippingAfterNewline, True) -> - (,) - SkippingAfterBlankLine - outputs - (SkippingAfterNewline, False) -> - (,)- SkippingAfterNewline- (continue ["\n",T.stripStart i] outputs)- (SkippingAfterBlankLine, True) -> - (,) - SkippingAfterBlankLine - outputs - (SkippingAfterBlankLine, False) -> - (,)- SkippingAfterNewline- (continue ["\n",T.stripStart i] (NonEmpty.cons [] outputs)) - (ContinuingNonemptyLine, _) -> - (,)- SkippingAfterNewline- (continue ["\n",i] outputs)- advanceLast - :: (ParagraphsState, NonEmpty [T.Text]) - -> T.Text - -> (ParagraphsState, NonEmpty [T.Text])- advanceLast (s,outputs) i = - case (s, blank i) of- (SkippingAfterStreamStart, True) -> - (,) - SkippingAfterStreamStart - outputs- (SkippingAfterStreamStart, False) -> - (,)- ContinuingNonemptyLine- (continue [T.stripStart i] outputs)- (SkippingAfterNewline, True) -> - (,) - SkippingAfterNewline - outputs- (SkippingAfterNewline, False) -> - (,)- ContinuingNonemptyLine- (continue [T.stripStart i] outputs)- (SkippingAfterBlankLine, True) -> - (,)- SkippingAfterBlankLine- outputs - (SkippingAfterBlankLine, False) -> - (,)- ContinuingNonemptyLine- (continue [T.stripStart i] (NonEmpty.cons [] outputs))- (ContinuingNonemptyLine, _) -> - (,)- ContinuingNonemptyLine- (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)----------------------------------------------------------------------------------{- $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+{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- 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 + , words + , lines + , paragraphs + , sections + -- * Textual + -- $textual + , textualSplit + , textualBreak + ) where + +import Prelude hiding (lines,words) +import Data.Char +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 qualified Data.List +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty + +{- $setup + +>>> :set -XFlexibleContexts +>>> import Data.String hiding (lines,words) +>>> import Data.Text (Text) +>>> import Control.Applicative +>>> import Control.Monad.Trans.Except +>>> import qualified Control.Foldl as L +>>> import Control.Foldl.Transduce + +-} + +data Pair a b = Pair !a !b + +{-| 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 '\xc3': 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 (return (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 (return . 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 '\xc3': 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 of text into lines, removing the newlines. + +>>> L.fold (L.groups lines (surround [T.pack "x"] []) L.list) (map T.pack ["line 1\n line 2\n"]) +["x","line 1","x"," line 2"] + +>>> L.fold (L.groups lines newline L.list) (map T.pack ["line 1\n line 2\n"]) +["line 1","\n"," line 2","\n"] + + Used with 'L.transduce', it simply removes newlines: + +>>> L.fold (L.transduce lines L.list) (map T.pack ["line 1\n line 2\n"]) +["line 1"," line 2"] +-} +lines :: L.Transducer T.Text T.Text () +lines = L.Transducer step False done + where + step previousnl txt = + if Data.Text.null txt + then + (previousnl,[],[]) + else + let + lastc = Data.Text.last txt == '\n' + txts = T.lines txt + in + case (previousnl,txts) of + (_,[]) -> error "never happens" + (True,_) -> (lastc, [], map pure txts) + (False,t:ts) -> (lastc, [t], map pure ts) + + done _ = ((),[],[]) + + +data WordsState = + NoLastChar + | LastCharSpace + | LastCharNotSpace + +{-| Splits a stream of text into words, removing whitespace. + +>>> L.fold (folds words L.list L.list) (map T.pack [" a","aa ", "bb c","cc dd ","ee f","f"]) +[["a","aa"],["bb"],["c","cc"],["dd"],["ee"],["f","f"]] + + Used with 'L.transduce', it simply removes all whitespace: + +>>> L.fold (L.transduce words L.list) (map T.pack [" a","aa ", "bb c","cc dd ","ee f","f"]) +["a","aa","bb","c","cc","dd","ee","f","f"] +-} +words :: L.Transducer T.Text T.Text () +words = L.Transducer step NoLastChar done + where + step tstate txt + | Data.Text.null txt = (tstate,[],[]) + | blank txt = + case tstate of + NoLastChar -> (NoLastChar,[],[]) + _ -> (LastCharSpace,[],[]) + | otherwise = + let nextstate = + if isSpace (T.last txt) + then LastCharSpace + else LastCharNotSpace + (oldgroup,newgroups) = case (tstate, T.words txt) of + (NoLastChar,w:ws) -> + ([w],map pure ws) + (LastCharSpace,ws) -> + ([],map pure ws) + (LastCharNotSpace,w:ws) -> + if isSpace (T.head txt) + then ([],map pure (w:ws)) + else ([w],map pure ws) + (_,[]) -> error "never happens, txt not blank" + in (nextstate,oldgroup,newgroups) + done _ = ((),[],[]) + + +data ParagraphsState = + SkippingAfterStreamStart + | SkippingAfterNewline + | SkippingAfterBlankLine + | ContinuingNonemptyLine + +{-| Splits a stream of text into paragraphs, removing empty lines and trimming + newspace from the start of each line. + +>>> map mconcat (L.fold (folds paragraphs L.list L.list) (map T.pack [" \n aaa","\naa ", " \n\nbb\n"])) +["aaa\naa \n","bb\n"] + + Used with 'L.transduce', it removes empty lines and trims newspace from the + start of each line. +-} +paragraphs :: L.Transducer T.Text T.Text () +paragraphs = L.Transducer step SkippingAfterStreamStart done + where + step tstate txt + | Data.Text.null txt = + (tstate,[],[]) + | otherwise = + let (initlines,lastline) = splittedLines txt + (tstate', outputsreversed) = + advanceLast + (foldl' + advance + (tstate,pure []) + initlines) + lastline + (xs :| xss) = fmap reverse (NonEmpty.reverse outputsreversed) + in (tstate',xs,xss) + done _ = + ((),[],[]) + splittedLines :: T.Text -> ([T.Text],T.Text) + splittedLines nonEmptyChunk = + let splitted = + Data.Text.lines nonEmptyChunk + ++ + if T.last nonEmptyChunk == '\n' then [mempty] else mempty + in (init splitted, last splitted) -- unsafe with empty lists!!! + advance + :: (ParagraphsState, NonEmpty [T.Text]) + -> T.Text + -> (ParagraphsState, NonEmpty [T.Text]) + advance (s,outputs) i = + case (s, blank i) of + (SkippingAfterStreamStart, True) -> + (,) + SkippingAfterStreamStart + outputs + (SkippingAfterStreamStart, False) -> + (,) + SkippingAfterNewline + (continue ["\n",T.stripStart i] outputs) + (SkippingAfterNewline, True) -> + (,) + SkippingAfterBlankLine + outputs + (SkippingAfterNewline, False) -> + (,) + SkippingAfterNewline + (continue ["\n",T.stripStart i] outputs) + (SkippingAfterBlankLine, True) -> + (,) + SkippingAfterBlankLine + outputs + (SkippingAfterBlankLine, False) -> + (,) + SkippingAfterNewline + (continue ["\n",T.stripStart i] (NonEmpty.cons [] outputs)) + (ContinuingNonemptyLine, _) -> + (,) + SkippingAfterNewline + (continue ["\n",i] outputs) + advanceLast + :: (ParagraphsState, NonEmpty [T.Text]) + -> T.Text + -> (ParagraphsState, NonEmpty [T.Text]) + advanceLast (s,outputs) i = + case (s, blank i) of + (SkippingAfterStreamStart, True) -> + (,) + SkippingAfterStreamStart + outputs + (SkippingAfterStreamStart, False) -> + (,) + ContinuingNonemptyLine + (continue [T.stripStart i] outputs) + (SkippingAfterNewline, True) -> + (,) + SkippingAfterNewline + outputs + (SkippingAfterNewline, False) -> + (,) + ContinuingNonemptyLine + (continue [T.stripStart i] outputs) + (SkippingAfterBlankLine, True) -> + (,) + SkippingAfterBlankLine + outputs + (SkippingAfterBlankLine, False) -> + (,) + ContinuingNonemptyLine + (continue [T.stripStart i] (NonEmpty.cons [] outputs)) + (ContinuingNonemptyLine, _) -> + (,) + ContinuingNonemptyLine + (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) + +------------------------------------------------------------------------------ + +{- $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
tests/doctests.hs view
@@ -1,11 +1,11 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest - [- "src/Control/Foldl/Transduce.hs",- "src/Control/Foldl/Transduce/ByteString.hs",- "src/Control/Foldl/Transduce/Text.hs"- ]+module Main where + +import Test.DocTest + +main :: IO () +main = doctest + [ + "src/Control/Foldl/Transduce.hs", + "src/Control/Foldl/Transduce/ByteString.hs", + "src/Control/Foldl/Transduce/Text.hs" + ]
tests/tests.hs view
@@ -1,243 +1,243 @@-module Main where--import Prelude hiding (splitAt,lines,words)-import Data.Char-import Data.String hiding (lines,words)-import Data.Monoid-import Data.Bifunctor-import qualified Data.List (intersperse,splitAt)-import qualified Data.List.Split as Split-import qualified Data.Monoid.Factorial as SFM-import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.QuickCheck--import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import qualified Control.Foldl as L-import Control.Foldl.Transduce-import Control.Foldl.Transduce.Text--{- $quickcheck-- Notes for quickchecking on the REPL:--cabal repl tests-:t sample-sample :: Show a => Gen a -> IO ()-sample (arbitrary :: Gen WordA)---}--main :: IO ()-main = defaultMain tests--testCaseEq :: (Eq a, Show a) => TestName -> a -> a -> TestTree-testCaseEq name a1 a2 = testCase name (assertEqual "" a1 a2)--blank :: T.Text -> Bool-blank = T.all isSpace--nl :: T.Text-nl = T.pack "\n"--sp :: T.Text-sp = T.pack " "--c :: T.Text-c = T.pack "c"--{- $words---}--newtype WordA = WordA { getWord :: T.Text } deriving (Show)--instance Arbitrary WordA where- arbitrary = do- firstChar <- oneof [pure ' ', pure '\n', arbitrary]- lastChar <- oneof [pure ' ', pure '\n', arbitrary]- middle <- listOf (frequency [(1,pure ' '),(4,arbitrary)])- return (WordA (T.pack (firstChar : (middle ++ [lastChar]))))--{- $paragraphs---}--newtype TextChunksA = TextChunksA { getChunks :: [T.Text] } deriving (Show)--instance Arbitrary TextChunksA where- arbitrary = flip suchThat (not . blank . mconcat . getChunks) (do- TextChunksA <$> partz)- where- chunkz = frequency [- (20::Int, flip T.replicate sp <$> choose (1,40)) - , (20, flip T.replicate sp <$> choose (1,3)) - , (50, pure nl)- , (20, flip T.replicate c <$> choose (1,30))- , (20, flip T.replicate c <$> choose (1,3))- ]- combined = mconcat <$> vectorOf 40 chunkz - partitions = infiniteListOf (choose (1::Int,7))- partz = partition [] <$> combined <*> partitions- partition :: [T.Text] -> T.Text -> [Int] -> [T.Text]- partition accum text (x:xs) =- if x >= T.length text - then reverse (text:accum)- else - let (point,rest) = T.splitAt x text - in - partition (point:accum) rest xs- partition _ _ [] = error "never happens"- shrink (TextChunksA texts) = - let removeIndex i xs = - let (xs',xs'') = Data.List.splitAt i xs- in xs' ++ tail xs'' - l = length texts- in - if l == 1 - then []- else map (\i -> TextChunksA (removeIndex i texts)) [0..l-1] --paragraphsBaseline - :: T.Text -> [T.Text] -paragraphsBaseline = - map (T.unlines . map T.stripStart . T.lines)- . map mconcat - . map (`mappend` [nl])- . map (Data.List.intersperse nl)- . filter (not . null) - . Split.splitWhen blank - . T.lines--ignoreLastNewline :: [T.Text] -> [T.Text]-ignoreLastNewline ts = - let - lastt = last ts- lastt' = if T.last lastt == '\n' then T.init lastt else lastt - in init ts ++ [lastt']---- (paragraphs,chunks)-splittedParagraphs :: T.Text -> [Int] -> [([T.Text],[T.Text])]-splittedParagraphs txt splitsizes = - let - splitted = paragraphsBaseline txt- in - zip (repeat splitted) (map (flip T.chunksOf txt) splitsizes)--paragraphsUnderTest- :: [T.Text] -> [T.Text] -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 - " \n \n\n \n \n \- \a aa aaa \nb bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb bb \n \- \ ccccccccccccccccccccccc cccccccc \n\n \n \n\n ccc\ - \ \n \n \nd\n\n\ne \- \\n" - -paragraph02 :: T.Text-paragraph02 = T.pack " cc "--tests :: TestTree-tests = - testGroup "Tests" - [- testGroup "surround" - [- testCaseEq "surroundempty" - "prefixsuffix"- (L.fold (transduce (surround "prefix" "suffix") L.list) "")- ],- testGroup "chunksOf" - [- testCaseEq "emptyList3"- ([]::[[Int]])- (L.fold (folds (chunksOf 3) L.list L.list) [])- ,- testCaseEq "size1" - ([[1],[2],[3],[4],[5],[6],[7]]::[[Int]])- (L.fold (folds (chunksOf 1) L.list L.list) [1..7])- ,- testCaseEq "size3" - ([[1,2,3],[4,5,6],[7]]::[[Int]])- (L.fold (folds (chunksOf 3) L.list L.list) [1..7])- ],- testGroup "textualBreak"- [- testCaseEq "beginwithdot"- ".bb"- (L.fold (bisect (textualBreak (=='.')) ignore (reify id) L.mconcat) ["aa",".bb"])- ,- testCaseEq "endwithdot"- "."- (L.fold (bisect (textualBreak (=='.')) ignore (reify id) L.mconcat) ["aa","bb."])- ],- testGroup "newline"- [- testCaseEq "newlineempty"- (T.pack "\n")- (mconcat (L.fold (transduce newline L.list) (map T.pack [])))- ,- testCaseEq "newlinenull"- (T.pack "\n")- (mconcat (L.fold (transduce newline L.list) (map T.pack [""])))- ],- testGroup "words" - [ - testGroup "quickcheck" - [ - testProperty "quickcheck1" (\chunks -> -- list of words - let tchunks = fmap getWord chunks - in- TL.words (TL.fromChunks tchunks)- ==- (fmap TL.fromChunks (L.fold (folds words L.list L.list) tchunks)))- ]- ],- testGroup "paragraphs" - [- testCase "paragraphs01"- (mapM_- (\(x,y) -> assertEqual "" (ignoreLastNewline x) (ignoreLastNewline (paragraphsUnderTest y))) - (splittedParagraphs paragraph01 [1..7])),- testCaseEq "newlineAtEnd"- (map T.pack ["aa\n"]) - (paragraphsUnderTest (map T.pack ["a","a","\n"])),- testCaseEq "noNewlineAtEnd"- (map T.pack ["aa"]) - (paragraphsUnderTest (map T.pack ["a","a"])),- testGroup "quickcheck" - [ - testProperty "quickcheck1" (\(TextChunksA chunks) ->- ignoreLastNewline (paragraphsUnderTest chunks)- ==- 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"]))- ]- ]-+module Main where + +import Prelude hiding (splitAt,lines,words) +import Data.Char +import Data.String hiding (lines,words) +import Data.Monoid +import Data.Bifunctor +import qualified Data.List (intersperse,splitAt) +import qualified Data.List.Split as Split +import qualified Data.Monoid.Factorial as SFM +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +import qualified Control.Foldl as L +import Control.Foldl.Transduce +import Control.Foldl.Transduce.Text + +{- $quickcheck + + Notes for quickchecking on the REPL: + +cabal repl tests +:t sample +sample :: Show a => Gen a -> IO () +sample (arbitrary :: Gen WordA) + +-} + +main :: IO () +main = defaultMain tests + +testCaseEq :: (Eq a, Show a) => TestName -> a -> a -> TestTree +testCaseEq name a1 a2 = testCase name (assertEqual "" a1 a2) + +blank :: T.Text -> Bool +blank = T.all isSpace + +nl :: T.Text +nl = T.pack "\n" + +sp :: T.Text +sp = T.pack " " + +c :: T.Text +c = T.pack "c" + +{- $words + +-} + +newtype WordA = WordA { getWord :: T.Text } deriving (Show) + +instance Arbitrary WordA where + arbitrary = do + firstChar <- oneof [pure ' ', pure '\n', arbitrary] + lastChar <- oneof [pure ' ', pure '\n', arbitrary] + middle <- listOf (frequency [(1,pure ' '),(4,arbitrary)]) + return (WordA (T.pack (firstChar : (middle ++ [lastChar])))) + +{- $paragraphs + +-} + +newtype TextChunksA = TextChunksA { getChunks :: [T.Text] } deriving (Show) + +instance Arbitrary TextChunksA where + arbitrary = flip suchThat (not . blank . mconcat . getChunks) (do + TextChunksA <$> partz) + where + chunkz = frequency [ + (20::Int, flip T.replicate sp <$> choose (1,40)) + , (20, flip T.replicate sp <$> choose (1,3)) + , (50, pure nl) + , (20, flip T.replicate c <$> choose (1,30)) + , (20, flip T.replicate c <$> choose (1,3)) + ] + combined = mconcat <$> vectorOf 40 chunkz + partitions = infiniteListOf (choose (1::Int,7)) + partz = partition [] <$> combined <*> partitions + partition :: [T.Text] -> T.Text -> [Int] -> [T.Text] + partition accum text (x:xs) = + if x >= T.length text + then reverse (text:accum) + else + let (point,rest) = T.splitAt x text + in + partition (point:accum) rest xs + partition _ _ [] = error "never happens" + shrink (TextChunksA texts) = + let removeIndex i xs = + let (xs',xs'') = Data.List.splitAt i xs + in xs' ++ tail xs'' + l = length texts + in + if l == 1 + then [] + else map (\i -> TextChunksA (removeIndex i texts)) [0..l-1] + +paragraphsBaseline + :: T.Text -> [T.Text] +paragraphsBaseline = + map (T.unlines . map T.stripStart . T.lines) + . map mconcat + . map (`mappend` [nl]) + . map (Data.List.intersperse nl) + . filter (not . null) + . Split.splitWhen blank + . T.lines + +ignoreLastNewline :: [T.Text] -> [T.Text] +ignoreLastNewline ts = + let + lastt = last ts + lastt' = if T.last lastt == '\n' then T.init lastt else lastt + in init ts ++ [lastt'] + +-- (paragraphs,chunks) +splittedParagraphs :: T.Text -> [Int] -> [([T.Text],[T.Text])] +splittedParagraphs txt splitsizes = + let + splitted = paragraphsBaseline txt + in + zip (repeat splitted) (map (flip T.chunksOf txt) splitsizes) + +paragraphsUnderTest + :: [T.Text] -> [T.Text] +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 + " \n \n\n \n \n \ + \a aa aaa \nb bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb bb \n \ + \ ccccccccccccccccccccccc cccccccc \n\n \n \n\n ccc\ + \ \n \n \nd\n\n\ne \ + \\n" + +paragraph02 :: T.Text +paragraph02 = T.pack " cc " + +tests :: TestTree +tests = + testGroup "Tests" + [ + testGroup "surround" + [ + testCaseEq "surroundempty" + "prefixsuffix" + (L.fold (transduce (surround "prefix" "suffix") L.list) "") + ], + testGroup "chunksOf" + [ + testCaseEq "emptyList3" + ([]::[[Int]]) + (L.fold (folds (chunksOf 3) L.list L.list) []) + , + testCaseEq "size1" + ([[1],[2],[3],[4],[5],[6],[7]]::[[Int]]) + (L.fold (folds (chunksOf 1) L.list L.list) [1..7]) + , + testCaseEq "size3" + ([[1,2,3],[4,5,6],[7]]::[[Int]]) + (L.fold (folds (chunksOf 3) L.list L.list) [1..7]) + ], + testGroup "textualBreak" + [ + testCaseEq "beginwithdot" + ".bb" + (L.fold (bisect (textualBreak (=='.')) ignore (reify id) L.mconcat) ["aa",".bb"]) + , + testCaseEq "endwithdot" + "." + (L.fold (bisect (textualBreak (=='.')) ignore (reify id) L.mconcat) ["aa","bb."]) + ], + testGroup "newline" + [ + testCaseEq "newlineempty" + (T.pack "\n") + (mconcat (L.fold (transduce newline L.list) (map T.pack []))) + , + testCaseEq "newlinenull" + (T.pack "\n") + (mconcat (L.fold (transduce newline L.list) (map T.pack [""]))) + ], + testGroup "words" + [ + testGroup "quickcheck" + [ + testProperty "quickcheck1" (\chunks -> -- list of words + let tchunks = fmap getWord chunks + in + TL.words (TL.fromChunks tchunks) + == + (fmap TL.fromChunks (L.fold (folds words L.list L.list) tchunks))) + ] + ], + testGroup "paragraphs" + [ + testCase "paragraphs01" + (mapM_ + (\(x,y) -> assertEqual "" (ignoreLastNewline x) (ignoreLastNewline (paragraphsUnderTest y))) + (splittedParagraphs paragraph01 [1..7])), + testCaseEq "newlineAtEnd" + (map T.pack ["aa\n"]) + (paragraphsUnderTest (map T.pack ["a","a","\n"])), + testCaseEq "noNewlineAtEnd" + (map T.pack ["aa"]) + (paragraphsUnderTest (map T.pack ["a","a"])), + testGroup "quickcheck" + [ + testProperty "quickcheck1" (\(TextChunksA chunks) -> + ignoreLastNewline (paragraphsUnderTest chunks) + == + 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"])) + ] + ] +