-- * FreeT Splitters
, chunksOf
, splitsWith
- , split
+ , splits
-- , groupsBy
-- , groups
, lines
) where
import Control.Exception (throwIO, try)
+import Control.Applicative ((<*))
import Control.Monad (liftM, unless, join)
import Control.Monad.Trans.State.Strict (StateT(..), modify)
import Data.Monoid ((<>))
import qualified Pipes.ByteString as PB
import qualified Pipes.Text.Internal as PE
import Pipes.Text.Internal (Codec(..))
--- import Pipes.Text.Parse (nextChar, drawChar, unDrawChar, peekChar, isEndOfChars )
-
import Pipes.Core (respond, Server')
import qualified Pipes.Parse as PP
import Pipes.Parse (Parser, concats, intercalates, FreeT(..))
return (yield suffix >> p')
{-# INLINABLE splitAt #-}
--- | Split a text stream into 'FreeT'-delimited text streams of fixed size
-chunksOf
- :: (Monad m, Integral n)
- => n -> Lens' (Producer Text m r)
- (FreeT (Producer Text m) m r)
-chunksOf n k p0 = fmap concats (k (FreeT (go p0)))
- where
- go p = do
- x <- next p
- return $ case x of
- Left r -> PP.Pure r
- Right (txt, p') -> PP.Free $ do
- p'' <- (yield txt >> p') ^. splitAt n
- return $ PP.FreeT (go p'')
-{-# INLINABLE chunksOf #-}
{-| Split a text stream in two, where the first text stream is the longest
consecutive group of text that satisfy the predicate
from p = for p (each . T.unpack)
{-# INLINABLE packChars #-}
+
+-- | Split a text stream into 'FreeT'-delimited text streams of fixed size
+chunksOf
+ :: (Monad m, Integral n)
+ => n -> Lens' (Producer Text m r)
+ (FreeT (Producer Text m) m r)
+chunksOf n k p0 = fmap concats (k (FreeT (go p0)))
+ where
+ go p = do
+ x <- next p
+ return $ case x of
+ Left r -> PP.Pure r
+ Right (txt, p') -> PP.Free $ do
+ p'' <- (yield txt >> p') ^. splitAt n
+ return $ PP.FreeT (go p'')
+{-# INLINABLE chunksOf #-}
+
+
{-| Split a text stream into sub-streams delimited by characters that satisfy the
predicate
-}
{-# INLINABLE splitsWith #-}
-- | Split a text stream using the given 'Char' as the delimiter
-split :: (Monad m)
+splits :: (Monad m)
=> Char
- -> Producer Text m r
- -> FreeT (Producer Text m) m r
-split c = splitsWith (c ==)
-{-# INLINABLE split #-}
+ -> Lens' (Producer Text m r)
+ (FreeT (Producer Text m) m r)
+splits c k p =
+ fmap (PP.intercalates (yield (T.singleton c))) (k (splitsWith (c ==) p))
+{-# INLINABLE splits #-}
+
+{-| Isomorphism between a stream of 'Text' and groups of equivalent 'Char's , using the
+ given equivalence relation
+-}
+groupsBy
+ :: Monad m
+ => (Char -> Char -> Bool)
+ -> Lens' (Producer Text m x) (FreeT (Producer Text m) m x)
+groupsBy equals k p0 = fmap concats (k (PP.FreeT (go p0))) where
+ go p = do x <- next p
+ case x of Left r -> return (PP.Pure r)
+ Right (bs, p') -> case T.uncons bs of
+ Nothing -> go p'
+ Just (c, _) -> do return $ PP.Free $ do
+ p'' <- (yield bs >> p')^.span (equals c)
+ return $ PP.FreeT (go p'')
+{-# INLINABLE groupsBy #-}
+
+
+-- | Like 'groupsBy', where the equality predicate is ('==')
+groups
+ :: Monad m
+ => Lens' (Producer Text m x) (FreeT (Producer Text m) m x)
+groups = groupsBy (==)
+{-# INLINABLE groups #-}
+
{-| Split a text stream into 'FreeT'-delimited lines
-}
lines
- :: (Monad m) => Producer Text m r -> FreeT (Producer Text m) m r
-lines p0 = PP.FreeT (go0 p0)
+ :: (Monad m) => Iso' (Producer Text m r) (FreeT (Producer Text m) m r)
+lines = Data.Profunctor.dimap _lines (fmap _unlines)
where
- go0 p = do
- x <- next p
- case x of
- Left r -> return (PP.Pure r)
- Right (txt, p') ->
- if (T.null txt)
- then go0 p'
- else return $ PP.Free $ go1 (yield txt >> p')
- go1 p = do
- p' <- p ^. break ('\n' ==)
- return $ PP.FreeT $ do
- x <- nextChar p'
- case x of
- Left r -> return $ PP.Pure r
- Right (_, p'') -> go0 p''
+ _lines p0 = PP.FreeT (go0 p0)
+ where
+ go0 p = do
+ x <- next p
+ case x of
+ Left r -> return (PP.Pure r)
+ Right (txt, p') ->
+ if (T.null txt)
+ then go0 p'
+ else return $ PP.Free $ go1 (yield txt >> p')
+ go1 p = do
+ p' <- p ^. break ('\n' ==)
+ return $ PP.FreeT $ do
+ x <- nextChar p'
+ case x of
+ Left r -> return $ PP.Pure r
+ Right (_, p'') -> go0 p''
+ -- _unlines
+ -- :: Monad m
+ -- => FreeT (Producer Text m) m x -> Producer Text m x
+ _unlines = PP.concats . PP.transFreeT addNewline
+
+ -- addNewline
+ -- :: Monad m => Producer Text m r -> Producer Text m r
+ addNewline p = p <* yield (T.singleton '\n')
{-# INLINABLE lines #-}
-- | Split a text stream into 'FreeT'-delimited words
words
- :: (Monad m) => Producer Text m r -> FreeT (Producer Text m) m r
-words = go
+ :: (Monad m) => Iso' (Producer Text m r) (FreeT (Producer Text m) m r)
+words = Data.Profunctor.dimap go (fmap _unwords)
where
go p = PP.FreeT $ do
x <- next (p >-> dropWhile isSpace)
Right (bs, p') -> PP.Free $ do
p'' <- (yield bs >> p') ^. break isSpace
return (go p'')
+ _unwords = PP.intercalates (yield $ T.singleton ' ')
+
{-# INLINABLE words #-}
-
-
-
{-| 'intercalate' concatenates the 'FreeT'-delimited text streams after
interspersing a text stream in between them
-}
-}
{- $reexports
- @Pipes.Text.Parse@ re-exports 'nextChar', 'drawChar', 'unDrawChar', 'peekChar', and 'isEndOfChars'.
@Data.Text@ re-exports the 'Text' type.
- @Pipes.Parse@ re-exports 'input', 'concat', and 'FreeT' (the type).
+ @Pipes.Parse@ re-exports 'input', 'concat', 'FreeT' (the type) and the 'Parse' synonym.
-}
+++ /dev/null
--- | Parsing utilities for texts, in the style of @pipes-parse@ and @Pipes.ByteString.Parse@
-
-module Pipes.Text.Parse (
- -- * Parsers
- nextChar,
- drawChar,
- unDrawChar,
- peekChar,
- isEndOfChars,
- take,
- takeWhile
- ) where
-
-import Control.Monad.Trans.State.Strict (StateT, modify)
-import qualified Data.Text as T
-import Data.Text (Text)
-
-import Pipes
-import qualified Pipes.Parse as PP
-
-import Prelude hiding (take, takeWhile)
-
-{-| Consume the first character from a 'Text' stream
-
- 'next' either fails with a 'Left' if the 'Producer' has no more characters or
- succeeds with a 'Right' providing the next character and the remainder of the
- 'Producer'.
--}
-nextChar
- :: (Monad m)
- => Producer Text m r
- -> m (Either r (Char, Producer Text m r))
-nextChar = go
- where
- go p = do
- x <- next p
- case x of
- Left r -> return (Left r)
- Right (txt, p') -> case (T.uncons txt) of
- Nothing -> go p'
- Just (c, txt') -> return (Right (c, yield txt' >> p'))
-{-# INLINABLE nextChar #-}
-
-{-| Draw one 'Char' from the underlying 'Producer', returning 'Nothing' if the
- 'Producer' is empty
--}
-drawChar :: (Monad m) => StateT (Producer Text m r) m (Maybe Char)
-drawChar = do
- x <- PP.draw
- case x of
- Nothing -> return Nothing
- Just txt -> case (T.uncons txt) of
- Nothing -> drawChar
- Just (c, txt') -> do
- PP.unDraw txt'
- return (Just c)
-{-# INLINABLE drawChar #-}
-
--- | Push back a 'Char' onto the underlying 'Producer'
-unDrawChar :: (Monad m) => Char -> StateT (Producer Text m r) m ()
-unDrawChar c = modify (yield (T.singleton c) >>)
-{-# INLINABLE unDrawChar #-}
-
-{-| 'peekChar' checks the first 'Char' in the stream, but uses 'unDrawChar' to
- push the 'Char' back
-
-> peekChar = do
-> x <- drawChar
-> case x of
-> Left _ -> return ()
-> Right c -> unDrawChar c
-> return x
--}
-peekChar :: (Monad m) => StateT (Producer Text m r) m (Maybe Char)
-peekChar = do
- x <- drawChar
- case x of
- Nothing -> return ()
- Just c -> unDrawChar c
- return x
-{-# INLINABLE peekChar #-}
-
-{-| Check if the underlying 'Producer' has no more characters
-
- Note that this will skip over empty 'Text' chunks, unlike
- 'PP.isEndOfInput' from @pipes-parse@.
-
-> isEndOfChars = liftM isLeft peekChar
--}
-isEndOfChars :: (Monad m) => StateT (Producer Text m r) m Bool
-isEndOfChars = do
- x <- peekChar
- return (case x of
- Nothing -> True
- Just _-> False )
-{-# INLINABLE isEndOfChars #-}
-
-{-| @(take n)@ only allows @n@ characters to pass
-
- Unlike 'take', this 'PP.unDraw's unused characters
--}
-take :: (Monad m, Integral a) => a -> Pipe Text Text (StateT (Producer Text m r) m) ()
-take n0 = go n0 where
- go n
- | n <= 0 = return ()
- | otherwise = do
- txt <- await
- let len = fromIntegral (T.length txt)
- if (len > n)
- then do
- let n' = fromIntegral n
- lift . PP.unDraw $ T.drop n' txt
- yield $ T.take n' txt
- else do
- yield txt
- go (n - len)
-{-# INLINABLE take #-}
-
-{-| Take characters until they fail the predicate
-
- Unlike 'takeWhile', this 'PP.unDraw's unused characters
--}
-takeWhile
- :: (Monad m)
- => (Char -> Bool)
- -> Pipe Text Text (StateT (Producer Text m r) m) ()
-takeWhile predicate = go
- where
- go = do
- txt <- await
- let (prefix, suffix) = T.span predicate txt
- if (T.null suffix)
- then do
- yield txt
- go
- else do
- lift $ PP.unDraw suffix
- yield prefix
-{-# INLINABLE takeWhile #-}
projects / github / fretlink / text-pipes.git / commitdiff
