packages feed

pipes-transduce (empty) → 0.1.0.0

raw patch · 11 files changed

+918/−0 lines, 11 filesdep +basedep +bifunctorsdep +bytestringsetup-changed

Dependencies added: base, bifunctors, bytestring, comonad, conceit, containers, doctest, foldl, free, lens-family-core, monoid-subclasses, pipes, pipes-bytestring, pipes-concurrency, pipes-group, pipes-parse, pipes-safe, pipes-text, pipes-transduce, semigroupoids, semigroups, tasty, tasty-hunit, text, transformers, void

Files

+ CHANGELOG view
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2015, Daniel Díaz Carrete+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++* Neither the name of foldl-transduce nor the names of its+  contributors may be used to endorse or promote products derived from+  this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,20 @@+## What's in this library?++A **Fold'** datatype that consumes+[Producers](http://hackage.haskell.org/package/pipes-4.1.7/docs/Pipes.html#t:Producer)+from [pipes](http://hackage.haskell.org/package/pipes) and can be constructed+in a variety of ways, in particular from the more versatile folds in Gabriel+Gonzalez's [foldl](http://hackage.haskell.org/package/foldl) package.++## When to use this library?++I wanted a fold-like datatype for Producers that let me perform "bracketing"+operations (the folds in foldl are push-based and do not allow that) and had+"stopping on error" behaviour already baked in.++If you don't need any of that, you are better off just using **pipes** and/or+**foldl** by themselves. ++## Where can I find working examples for this library?++There are none yet.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pipes-transduce.cabal view
@@ -0,0 +1,81 @@+Name: pipes-transduce+Version: 0.1.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/pipes-transduce/issues+Synopsis: Interfacing pipes with foldl folds.+Description: Grab-bag of functions for interfacing pipes with foldl folds.+Category: Control++Extra-Source-Files:+    README.md+    CHANGELOG++Source-Repository head+    Type: git+    Location: git@github.com:danidiaz/pipes-transduce.git++Library+    HS-Source-Dirs: src+    Build-Depends:+        base          >= 4        && < 5   ,+        bytestring    >= 0.9.2.1  && < 0.11,+        text          >= 0.11.2.0 && < 1.3 ,+        transformers  >= 0.2.0.0  && < 0.5 ,+        containers                   < 0.6 ,+        bifunctors    == 5.*               ,+        semigroups    >= 0.15     && < 0.20,+        semigroupoids >= 5.0               ,+        foldl         >= 1.1      && < 2   ,+        comonad       == 4.*               ,+        free          == 4.*               ,         +        pipes         == 4.*               ,+        pipes-concurrency >= 2.0.2 && < 3  ,+        pipes-group >= 1.0.1               ,+        pipes-parse                        ,+        pipes-safe                         ,+        pipes-text    >= 0.0.1.0           ,+        pipes-bytestring                   ,+        monoid-subclasses == 0.4.*         ,+        void          >= 0.6      && < 1.0 ,+        conceit       >= 0.3.2.0  && < 0.4.0.0,+        lens-family-core >= 1.1 && < 2+    Exposed-Modules:+        Pipes.Transduce+        Pipes.Transduce.ByteString+        Pipes.Transduce.Text+        Pipes.Transduce.Internal+    GHC-Options: -O2 -Wall++test-suite doctests+  type:           exitcode-stdio-1.0+  ghc-options:    -Wall -threaded+  hs-source-dirs: tests+  main-is:        doctests.hs++  build-depends:+        base          >= 4.4 && < 5+      , free          == 4.*+      , pipes         == 4.*+      , doctest       >= 0.10.1+      , foldl         >= 1.1      && < 2++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+      , monoid-subclasses == 0.4.*+      , foldl               +      , pipes        +      , pipes-transduce
+ src/Pipes/Transduce.hs view
@@ -0,0 +1,137 @@+module Pipes.Transduce (+        -- * Producer folds+        Fold'+    ,   foldFallibly+    ,   Pipes.Transduce.Internal.fold+        -- * Building folds+        -- ** From foldl folds+        -- $foldl+    ,   withFold +    ,   withFoldIO +    ,   withFallibleFold+        -- ** From consumers+        -- $consumers+    ,   withConsumer +    ,   withConsumer' +    ,   withConsumerM +    ,   withConsumerM' +    ,   withSafeConsumer +    ,   withFallibleConsumer +        -- ** From parsers+        -- $parsers+    ,   withParser +    ,   withParserM +        -- ** From continuations+        -- $continuations+    ,   withCont +    ,   withCont' +    ,   withFallibleCont +    ,   withFallibleCont'  +        -- * Transducers+    ,   Transducer'+    ,   transduce+    ,   Delimited+    ,   Continuous+        -- * Building transducers+    ,   mapper +    ,   fallibleMapper +    ,   mapperFoldable +    ,   mapperEnumerable +    ,   transducer+    ,   fallibleTransducer+        -- * Transducer group operations+    ,   delimit+    ,   groups+    ,   folds+        -- * Utilities+    ,   trip+    ,   tripx+    ) where++import Pipes.Transduce.Internal ++import Data.Bifunctor+import Data.Monoid+import Data.Void+import Data.Foldable+import Control.Applicative+import Control.Applicative.Lift+import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.Free hiding (Pure)+import qualified Control.Foldl as Foldl+import Control.Exception+import Pipes +import Pipes.Lift (distribute) +--import Pipes.Prelude+import qualified Pipes.Prelude as Pipes++{- $setup+>>> :set -XOverloadedStrings+>>> import qualified Data.Text as T +>>> import qualified Data.Text.Lazy as TL +>>> import Control.Applicative+>>> import Control.Monad+>>> import qualified Control.Foldl as L+>>> import Pipes.Transduce +>>> import qualified Pipes.Transduce as PT+>>> import Pipes.Transduce.Text+>>> import qualified Pipes.Transduce.Text as PTT+-}++{-| +    Fail if the 'Producer' produces anything at all. The error value is what came+    out of the 'Producer'.++>>> PT.foldFallibly trip (mapM_ yield ['z']) +Left 'z'++>>> PT.foldFallibly trip (mapM_ yield []) +Right ((),())+-}+trip :: Fold' b b ()+trip = withFallibleCont' $ \producer -> do+    n <- next producer  +    return $ case n of +        Left r -> Right ((),r)+        Right (b,_) -> Left b++{-| +    Throw an exception if the 'Producer' produces anything at all++    __/BEWARE!/__ +    This 'Transducer' may throw 'AssertionFailed'.+    __/BEWARE!/__ ++>>> PT.foldFallibly tripx (mapM_ yield ['z']) +*** Exception: tripx+-}+tripx :: Fold' b e ()+tripx = withFallibleCont' $ \producer -> do+    n <- next producer  +    case n of +        Left r -> return (Right ((),r))+        Right _ -> throwIO (AssertionFailed "tripx")+++{- $foldl+ +    'Fold'' values can be created out of the more general folds of the @foldl@+    library, which are producer-agnostic.+-} ++{- $consumers+ +    'Fold'' values can be created out of 'Consumer's from the @pipes@ library.+-}++{- $parsers+ +    'Fold'' values can be created out of 'Parser's from the @pipes-parse@ library.+-}++{- $continuations+ +    The most general way of constructing 'Fold'' values is from an arbitrary+    function that consumes a 'Producer'.+-}
+ src/Pipes/Transduce/ByteString.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Pipes.Transduce.ByteString (+        -- * Collecting  input+        intoLazyBytes+        -- * Reading from handles+    ,   drainHandle+    ,   drainHandleFallibly+    ,   ChunkSize+    ,   chunkSize+    ,   chunkSizeDefault+    ) where++import Prelude hiding (lines)+import Data.Bifunctor+import Data.Monoid+import Data.Void+import Data.Foldable+import Data.ByteString+import qualified Data.ByteString.Lazy+import Data.Text hiding (lines)+import Data.Text.Encoding.Error (UnicodeException(..))+import Control.Applicative+import Control.Applicative.Lift+import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.Free hiding (Pure)+import qualified Control.Foldl as Foldl+import Control.Exception+import Pipes +import qualified Pipes.Text+import Pipes.Text.Encoding (decodeUtf8) +import Pipes.Lift (distribute) +--import Pipes.Prelude+import qualified Pipes.ByteString (hGetSome)+import qualified Pipes.Prelude as Pipes+import qualified Pipes.Group as Pipes+import qualified Pipes.Parse+import qualified Pipes.Text+import qualified Data.Text.Lazy+import Pipes.Concurrent+import Lens.Family (view)+import System.IO+import Data.ByteString.Lazy.Internal (defaultChunkSize)++import Pipes.Transduce++{- $setup+>>> :set -XOverloadedStrings+>>> import Control.Applicative+>>> import Control.Monad+>>> import qualified Pipes.Transduce as PT+-}++{-| +    Collect strict 'ByteString's into a lazy 'ByteString'.++>>> PT.fold intoLazyBytes (mapM_ yield ["aa","bb","cc"]) +("aabbcc",())++-}+intoLazyBytes :: Fold' ByteString e Data.ByteString.Lazy.ByteString+intoLazyBytes = fmap Data.ByteString.Lazy.fromChunks (withFold Foldl.list)++drainHandleFallibly +    :: Fold' ByteString e r +    -> ChunkSize +    -> Handle +    -> IO (Either e r) +drainHandleFallibly somefold (ChunkSize csize) handle =+    fmap (bimap id fst) (Pipes.Transduce.foldFallibly somefold (Pipes.ByteString.hGetSome csize handle))++drainHandle+    :: Fold' ByteString Void r +    -> ChunkSize  +    -> Handle +    -> IO r+drainHandle somefold (ChunkSize csize) handle =+    fmap fst (Pipes.Transduce.fold somefold (Pipes.ByteString.hGetSome csize handle))++{-| Maximum chunk size      +-}+newtype ChunkSize = ChunkSize Int deriving (Show,Eq,Ord,Num)++chunkSize :: Int -> ChunkSize+chunkSize = ChunkSize++chunkSizeDefault :: ChunkSize+chunkSizeDefault = chunkSize defaultChunkSize
+ src/Pipes/Transduce/Internal.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE EmptyDataDecls #-}++module Pipes.Transduce.Internal where++import Data.Bifunctor+import Data.Monoid+import Data.Void+import Data.Foldable+import Control.Applicative+import Control.Applicative.Lift+import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.Free hiding (Pure)+import qualified Control.Foldl as Foldl+import Control.Concurrent+import Control.Concurrent.Conceit+import Control.Exception+import Pipes +import Pipes.Lift (distribute) +import Pipes.Prelude+import qualified Pipes.Prelude as Pipes+import qualified Pipes.Group as Pipes+import qualified Pipes.Parse+import Pipes.Concurrent+import Pipes.Safe (SafeT, runSafeT)+import Lens.Family (folding)++{-| +    A computation in 'IO' that completely drains a 'Producer' of @b@ values,+    returning a value of type @a@, except when it fails early with an error of+    type @e@.+-}+newtype Fold' b e a = Fold' (Lift (Fold'_ b e) a) deriving (Functor)++data Fold'_ b e a = +         TrueFold (Foldl.FoldM (ExceptT e IO) b a)+       | ExhaustiveCont (forall r. Producer b IO r -> IO (Either e (a,r)))+       | NonexhaustiveCont (Producer b IO () -> IO (Either e a))+       deriving (Functor)++{-| +    'pure' creates a 'Fold'' that does nothing besides draining the+    'Producer'. ++    '<*>' feeds both folds with the data of the same 'Producer'. If any of+    them fails the combination fails.+-}+instance Applicative (Fold' b e) where+    pure a = Fold' (pure a)+    Fold' fa <*> Fold' a = Fold' (fa <*> a)++instance Applicative (Fold'_ b e) where+    pure a = ExhaustiveCont (\producer -> do+        r <- runEffect (producer >-> Pipes.drain)+        pure (Right (a,r)))++    TrueFold f1 <*> TrueFold f2 = TrueFold (f1 <*> f2)+    s1 <*> s2 = bifurcate (nonexhaustiveCont s1) (nonexhaustiveCont s2)  +        where +        bifurcate fs as = ExhaustiveCont (\producer -> do+            (outbox1,inbox1,seal1) <- spawn' (bounded 1)+            (outbox2,inbox2,seal2) <- spawn' (bounded 1)+            runConceit $+                (\f x r -> (f x,r))+                <$>+                Conceit (fs (fromInput inbox1) `finally` atomically seal1)+                <*>+                Conceit (as (fromInput inbox2) `finally` atomically seal2)+                <*>+                (_Conceit $+                    (runEffect (producer >-> Pipes.tee (toOutput outbox1 *> Pipes.drain) +                                         >->           (toOutput outbox2 *> Pipes.drain)))+                    `finally` atomically seal1 +                    `finally` atomically seal2))++instance Bifunctor (Fold'_ b) where+  bimap f g s = case s of+      TrueFold (Foldl.FoldM step start done) -> TrueFold (Foldl.FoldM +          (\previous input -> withExceptT f (step previous input))+          (withExceptT f start)+          (\final -> withExceptT f (fmap g (done final))))+      ExhaustiveCont u -> ExhaustiveCont (fmap (liftM  (bimap f (bimap g id))) u)+      NonexhaustiveCont h -> NonexhaustiveCont (fmap (liftM  (bimap f g)) h)++{-| +    'first' is useful to massage errors.+-}+instance Bifunctor (Fold' b) where+  bimap f g (Fold' s) = Fold' (case s of+      Pure a -> Pure (g a)+      Other o -> Other (bimap f g o))++instance (Monoid a) => Monoid (Fold' b e a) where+   mempty = pure mempty+   mappend s1 s2 = (<>) <$> s1 <*> s2++nonexhaustiveCont :: Fold'_ b e a -> Producer b IO () -> IO (Either e a)+nonexhaustiveCont (TrueFold e) = \producer -> runExceptT (Foldl.impurely Pipes.foldM e (hoist lift producer))+nonexhaustiveCont (ExhaustiveCont e) = \producer -> liftM (fmap fst) (e producer)+nonexhaustiveCont (NonexhaustiveCont u) = u++exhaustiveCont :: Fold'_ b e a -> Producer b IO r -> IO (Either e (a,r))+exhaustiveCont s = case s of +    TrueFold e -> \producer -> +        runExceptT (Foldl.impurely Pipes.foldM' e (hoist lift producer))+    ExhaustiveCont e -> e+    NonexhaustiveCont activity -> \producer -> do +        (outbox,inbox,seal) <- spawn' (bounded 1)+        runConceit $ +            (,) +            <$>+            Conceit (activity (fromInput inbox) `finally` atomically seal)+            <*>+            (_Conceit $+                (runEffect (producer >-> (toOutput outbox *> Pipes.drain)) +                `finally` atomically seal))+++withFallibleCont +    :: (Producer b IO () -> IO (Either e a)) -- ^+    -> Fold' b e a +withFallibleCont f = Fold' (Other (NonexhaustiveCont f))++withFallibleCont'  +    :: (forall r. Producer b IO r -> IO (Either e (a,r))) -- ^+    -> Fold' b e a +withFallibleCont' f = Fold' (Other (ExhaustiveCont f))++withCont +    :: (Producer b IO () -> IO a) -- ^+    -> Fold' b e a -- ^+withCont aFold = withFallibleCont $ fmap (fmap pure) $ aFold++withCont' +    :: (forall r. Producer b IO r -> IO (a,r)) -- ^+    -> Fold' b e a -- ^+withCont' aFold = withFallibleCont' $ fmap (fmap pure) aFold++withFold :: Foldl.Fold b a -> Fold' b e a +withFold aFold = Fold' (Other (TrueFold (Foldl.generalize aFold)))++withFoldIO :: Foldl.FoldM IO b a -> Fold' b e a +withFoldIO aFold = Fold' (Other (TrueFold (hoistFold lift aFold)))++hoistFold :: Monad m => (forall a. m a -> n a) -> Foldl.FoldM m i r -> Foldl.FoldM n i r +hoistFold g (Foldl.FoldM step begin done) = Foldl.FoldM (\s i -> g (step s i)) (g begin) (g . done)++withFallibleFold :: Foldl.FoldM (ExceptT e IO) b a -> Fold' b e a +withFallibleFold aFold = Fold' (Other (TrueFold aFold))++--withFoldM +--    :: MonadIO m +--    => (forall r. m (a,r) -> IO (Either e (c,r))) +--    -> Foldl.FoldM m b a +--    -> Fold' b e c +--withFoldM whittle aFoldM = withFallibleCont' $ \producer -> +--    whittle $ Foldl.impurely Pipes.Prelude.foldM' aFoldM (hoist liftIO producer)++withConsumer :: Consumer b IO () -> Fold' b e ()+withConsumer consumer = withCont $ \producer -> runEffect $ producer >-> consumer ++{-| Builds a 'Fold'' out of a 'Consumer' that never stops by itself.++-}+withConsumer' :: Consumer b IO Void -> Fold' b e ()+withConsumer' consumer = withCont' $ \producer -> fmap ((,) ()) $ runEffect $ producer >-> fmap absurd consumer ++withConsumerM :: MonadIO m +              => (m () -> IO (Either e a))  -- ^+              -> Consumer b m () +              -> Fold' b e a+withConsumerM whittle consumer = withFallibleCont $ \producer -> whittle $ runEffect $ (hoist liftIO producer) >-> consumer ++withConsumerM' :: MonadIO m +               => (forall r. m r -> IO (Either e (a,r))) -- ^+               -> Consumer b m Void+               -> Fold' b e a+withConsumerM' whittle consumer = withFallibleCont' $ \producer -> whittle $ runEffect $ (hoist liftIO producer) >-> fmap absurd consumer ++withSafeConsumer +    :: Consumer b (SafeT IO) Void -- ^+    -> Fold' b e ()+withSafeConsumer = withConsumerM' (fmap (\r -> Right ((),r)) . runSafeT)++withFallibleConsumer +    :: Consumer b (ExceptT e IO) Void -- ^+    -> Fold' b e ()+withFallibleConsumer = withConsumerM' (fmap (fmap (\r -> ((), r))) . runExceptT)+++withParser +    :: Pipes.Parse.Parser b IO (Either e a) -- ^+    -> Fold' b e a +withParser parser = withFallibleCont' $ \producer -> drainage $ Pipes.Parse.runStateT parser producer+  where+    drainage m = do +        (a,leftovers) <- m+        r <- runEffect (leftovers >-> Pipes.Prelude.drain)+        case a of+            Left e -> return (Left e)+            Right a' -> return (Right (a',r)) ++withParserM :: MonadIO m +            => (forall r. m (a,r) -> IO (Either e (c,r))) -- ^+            -> Pipes.Parse.Parser b m a -> Fold' b e c +withParserM f parser = withFallibleCont' $ \producer -> f $ drainage $ (Pipes.Parse.runStateT parser) (hoist liftIO producer)+  where+    drainage m = do +        (a,leftovers) <- m+        r <- runEffect (leftovers >-> Pipes.Prelude.drain)+        return (a,r)++------------------------------------------------------------------------------++{-| +    Run a 'Fold''.+-}+foldFallibly :: Fold' b e a -> Producer b IO r -> IO (Either e (a,r))+foldFallibly (Fold' (unLift -> s)) = exhaustiveCont s++{-| +    Run a 'Fold'' that never returns an error value (but which may still throw exceptions!)+-}+fold :: Fold' b Void a -> Producer b IO r -> IO (a,r)+fold (Fold' (unLift -> s)) = liftM (either absurd id) . exhaustiveCont s++{-| A transformation that takes the inputs of a 'Fold'' from type @a@ to type @b@.		++    Optionally, the transformation may delimit groups of elements in the+    stream. In that case the phantom type @x@ will be 'Delimited'. Otherwise, it will be+    'Continuous'.+-}+data Transducer' x b e a = +      M (b -> a)+    | F (b -> [a])+    | P (forall r. Producer b IO r -> Producer a IO r)+    | PE (forall r. Producer b IO r -> Producer a IO (Either e r))+    | S (forall r. Producer b IO r -> FreeT (Producer a IO) IO r)+    | SE (forall r. Producer b IO r -> FreeT (Producer a IO) IO (Either e r))++instance Functor (Transducer' x b e) where+  fmap = second++instance Bifunctor (Transducer' x b) where+  bimap f g s = case s of+      M x -> M (g . x)+      F x -> F (fmap g . x)+      P x -> P (\producer -> for (x producer) (Pipes.yield . g))+      PE x -> PE (\producer -> liftM (first f) (for (x producer) (Pipes.yield . g)))+      S x -> S (\producer -> transFreeT (\p -> for p (Pipes.yield . g)) (x producer))+      SE x -> SE (\producer -> liftM (first f) (transFreeT (\p -> (for p (Pipes.yield . g))) (x producer)))++mapper +    :: (a -> b) -- ^+    -> Transducer' Continuous a e b+mapper = M++fallibleM +    :: (a -> Either e b) -- ^+    -> Transducer' Continuous a e b  -- ^+fallibleM fallible = PE (\producer -> (runExceptT . distribute) (for (hoist lift producer) (\a -> do+    case fallible a of+        Left e -> lift (throwE e)+        Right b -> Pipes.yield b)))++fallibleMapper +    :: (a -> Either e b) -- ^+    -> Transducer' Continuous a e b  -- ^+fallibleMapper fallible = PE (\producer -> (runExceptT . distribute) (for (hoist lift producer) (\a -> do+    case fallible a of+        Left e -> lift (throwE e)+        Right b -> Pipes.yield b)))++mapperFoldable +    :: Foldable f +    => (a -> f b) -- ^+    -> Transducer' Continuous a e b -- ^+mapperFoldable f = F (Data.Foldable.toList . f)++mapperEnumerable +    :: Enumerable f +    => (a -> f IO b) -- ^+    -> Transducer' Continuous a e b  -- ^+mapperEnumerable enumerable = P (\producer -> for producer (enumerate . toListT . enumerable))++transducer +    :: (forall r. Producer b IO r -> Producer a IO r)  -- ^+    -> Transducer' Continuous b e a -- ^+transducer = P++fallibleTransducer +    :: (forall r. Producer b IO r -> Producer a IO (Either e r))  -- ^+    -> Transducer' Continuous b e a  -- ^+fallibleTransducer = PE++{-| Plug splitting functions from @pipes-group@ here.		++-}+delimit +    :: (forall r. Producer a IO r -> FreeT (Producer a' IO) IO r) -- ^+    -> Transducer' Continuous b e a -- ^+    -> Transducer' Delimited b e a' -- ^+delimit f t = case t of+    M func -> S (\producer -> f (producer >-> Pipes.Prelude.map func))+    F func -> S (\producer -> f (producer >-> mapFoldable func))+    P g -> S (f . g)+    PE g -> SE (f . g)+    S g -> S (f . Pipes.concats . g)+    SE g -> SE (f . Pipes.concats . g)++{-| Apply a 'Transducer'' ('Delimited' of 'Continuous') to a 'Fold''.		++-}+transduce :: Transducer' x b e a -> Fold' a e r -> Fold' b e r+transduce (M _) (Fold' (Pure x)) = +    Fold' (Pure x)+transduce (M f) (Fold' (Other s)) = (Fold' (Other (case s of+    TrueFold x -> TrueFold (Foldl.premapM f x)+    ExhaustiveCont x -> ExhaustiveCont (\producer -> x (producer >-> Pipes.Prelude.map f))+    NonexhaustiveCont x -> NonexhaustiveCont (\producer -> x (producer >-> Pipes.Prelude.map f)))))+transduce (F _) (Fold' (Pure x)) = +    Fold' (Pure x)+transduce (F f) (Fold' (Other s)) = (Fold' (Other (case s of+    TrueFold x -> TrueFold (Foldl.handlesM (folding f) x)+    ExhaustiveCont x -> ExhaustiveCont (\producer -> x (producer >-> Pipes.Prelude.mapFoldable f))+    NonexhaustiveCont x -> NonexhaustiveCont (\producer -> x (producer >-> Pipes.Prelude.mapFoldable f)))))+transduce (P f) (Fold' (unLift -> s)) = case s of+    NonexhaustiveCont x -> Fold' (Other (NonexhaustiveCont (x . f)))+    _ -> Fold' (Other (ExhaustiveCont (exhaustiveCont s . f)))+transduce (PE f) (Fold' (exhaustiveCont . unLift -> s)) = do+    Fold' (Other (ExhaustiveCont (\producer -> do+        (outbox,inbox,seal) <- spawn' (bounded 1)+        runConceit $ +            (\(r,()) r' -> (r,r'))+            <$>+            Conceit (s (fromInput inbox) `finally` atomically seal)+            <*>+            (Conceit $+                (runEffect (f producer >-> (toOutput outbox *> Pipes.drain)) +                `finally` atomically seal)))))+transduce (S f) somefold = transduce (P (Pipes.concats . f)) somefold+transduce (SE f) somefold = transduce (PE (Pipes.concats . f)) somefold++{-| Tweak each of the groups delimited by a 'Transducer''.		++-}+groups +    :: (forall r. Producer b IO r -> Producer b' IO r) -- ^+    -> Transducer' Delimited a e b  -- ^+    -> Transducer' Delimited a e b' -- ^+groups f t = case t of+    M func -> P (f . (\producer -> producer >-> Pipes.Prelude.map func))+    F func -> P (f . (\producer -> producer >-> mapFoldable func))+    P g -> P (f . g)+    PE g -> PE (f . g)+    S g -> S (Pipes.maps f . g)+    SE g -> SE (Pipes.maps f . g)++folds +    :: Fold' b Void b' -- ^+    -> Transducer' Delimited a e b +    -> Transducer' Continuous a e b'+folds somefold t = case t of+    M func -> folds somefold (P (\producer -> producer >-> Pipes.Prelude.map func))+    F func -> folds somefold (P (\producer -> producer >-> mapFoldable func))+    P g -> folds somefold (S (liftF . g))+    PE g -> folds somefold (SE (liftF . g))+    S g -> P (Pipes.concats . transFreeT ((\action -> lift action >>= (\(b',r) -> Pipes.yield b' >> return r)) . Pipes.Transduce.Internal.fold somefold) . g)+    SE g -> PE (Pipes.concats . transFreeT ((\action -> lift action >>= (\(b',r) -> Pipes.yield b' >> return r)) . Pipes.Transduce.Internal.fold somefold) . g)++data Delimited++data Continuous+
+ src/Pipes/Transduce/Text.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE RankNTypes #-}++module Pipes.Transduce.Text (+        -- * Collecting input+        intoLazyText +        -- * Splitting+    ,   lines+        -- * Grouping+    ,   foldedLines+        -- * Decoding+    ,   decoder+    ,   decoderx+    ,   utf8+    ,   utf8x+    ) where++import Prelude hiding (lines)+import Data.Bifunctor+import Data.Monoid+import Data.Void+import Data.Foldable+import Data.ByteString+import Data.Text hiding (lines)+import Data.Text.Encoding.Error (UnicodeException(..))+import Control.Applicative+import Control.Applicative.Lift+import Control.Monad+import Control.Monad.Trans.Except+import Control.Monad.Trans.Free hiding (Pure)+import qualified Control.Foldl as Foldl+import Control.Exception+import Pipes +import qualified Pipes.Text+import Pipes.Text.Encoding (decodeUtf8) +import Pipes.Lift (distribute) +--import Pipes.Prelude+import qualified Pipes.Prelude as Pipes+import qualified Pipes.Group as Pipes+import qualified Pipes.Parse+import qualified Pipes.Text+import qualified Data.Text.Lazy+import Pipes.Concurrent+import Lens.Family (view)++import Pipes.Transduce+import Pipes.Transduce.Internal++{- $setup+>>> :set -XOverloadedStrings+>>> import qualified Data.Text as T +>>> import qualified Data.Text.Lazy as TL +>>> import Control.Applicative+>>> import Control.Monad+>>> import qualified Control.Foldl as L+>>> import Pipes.Transduce +>>> import qualified Pipes.Transduce as PT+>>> import Pipes.Transduce.Text+>>> import qualified Pipes.Transduce.Text as PTT+-}++{-| +    Split the stream into lines, collect them into lazy 'Text' values, and pass+    them downstream. ++>>> PT.fold (transduce foldedLines (withFold L.list)) (mapM_ yield ["aa","aa\nbb","bb"]) +(["aaaa","bbbb"],())++-}+foldedLines +    :: Transducer' Continuous Text e Data.Text.Lazy.Text +foldedLines = +    Pipes.Transduce.folds +    (fmap Data.Text.Lazy.fromChunks (Pipes.Transduce.withFold Foldl.list)) +    (lines (Pipes.Transduce.mapper id))++{-| ++>>> PT.fold (transduce (groups (\p -> yield "x" >> p) (lines (transducer id))) intoLazyText) (mapM_ yield ["aa\n","bb"]) +("xaaxbb",())++-}+lines +    :: Transducer' Continuous a e Text -- ^+    -> Transducer' Delimited a e Text -- ^+lines sometrans = delimit (view Pipes.Text.lines) sometrans++{-| Plug decoding functions from @pipes-text@ here. ++    The first undecodable bytes will be the error value.+-}+decoder +    :: (forall r. Producer ByteString IO r -> Producer Text IO (Producer ByteString IO r))+    -> Transducer' Continuous ByteString ByteString Text -- ^+decoder f = PE (\producer -> f producer >>= \producer' -> lift (do+    n <- next producer'+    case n of+        Left r -> return (Right r)+        Right b -> return (Left (fst b))))++{-| Plug decoding functions from @pipes-text@ here. ++    __/BEWARE!/__ +    This 'Transducer'' may throw 'DecodeError' here.+    __/BEWARE!/__ +-}+decoderx+    :: (forall r. Producer ByteString IO r -> Producer Text IO (Producer ByteString IO r))+    -> Transducer' Continuous ByteString e Text -- ^+decoderx f = P (\producer -> f producer >>= \producer' -> lift (do+    n <- next producer'+    case n of+        Left r -> return r+        Right b -> throwIO (DecodeError "transducer decoding error" (Just (Data.ByteString.head (fst b)))))) ++{-| +    The first undecodable bytes will be the error value.++>>> PT.foldFallibly (transduce utf8 intoLazyText) (mapM_ yield ["aa"]) +Right ("aa",())++-}+utf8 :: Transducer' Continuous ByteString ByteString Text -- ^+utf8 = decoder decodeUtf8++{-| ++>>> PT.fold (transduce utf8x intoLazyText) (mapM_ yield ["aa"]) +("aa",())++    __/BEWARE!/__ +    This 'Transducer'' may throw 'DecodeError'.+    __/BEWARE!/__ +-}+utf8x :: Transducer' Continuous ByteString e Text -- ^+utf8x = decoderx decodeUtf8++{-| +    Collect strict 'Text's into a lazy 'Text'.++>>> PT.fold intoLazyText (mapM_ yield ["aa","bb","cc"]) +("aabbcc",())++-}+intoLazyText :: Fold' Text e Data.Text.Lazy.Text+intoLazyText = fmap Data.Text.Lazy.fromChunks (withFold Foldl.list)
+ tests/doctests.hs view
@@ -0,0 +1,11 @@+module Main where++import Test.DocTest++main :: IO ()+main = doctest +    [+        "src/Pipes/Transduce.hs"+    ,   "src/Pipes/Transduce/ByteString.hs"+    ,   "src/Pipes/Transduce/Text.hs"+    ]
+ tests/tests.hs view
@@ -0,0 +1,23 @@+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 Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++import qualified Control.Foldl as L++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = +    testGroup "Tests" +    []