pipes-text (empty) → 0.0.0.0
raw patch · 9 files changed
+1845/−0 lines, 9 filesdep +basedep +bytestringdep +pipessetup-changed
Dependencies added: base, bytestring, pipes, pipes-bytestring, pipes-group, pipes-parse, pipes-safe, profunctors, text, transformers
Files
- LICENSE +30/−0
- Pipes/Text.hs +1203/−0
- Pipes/Text/Internal/Codec.hs +215/−0
- Pipes/Text/Internal/Decoding.hs +147/−0
- README.md +17/−0
- Setup.hs +2/−0
- cbits/cbits.c +168/−0
- include/pipes_text_cbits.h +11/−0
- pipes-text.cabal +52/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-14, Gabriel Gonzalez, Tobias Florek, Michael Thompson++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 michaelt nor the names of other+ 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+OWNER 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.
+ Pipes/Text.hs view
@@ -0,0 +1,1203 @@+{-# LANGUAGE RankNTypes, TypeFamilies, BangPatterns, CPP #-}+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif+{-| This module provides @pipes@ utilities for \"text streams\", which are+ streams of 'Text' chunks. The individual chunks are uniformly @strict@, but + a 'Producer' can be converted to and from lazy 'Text's, though this is generally + unwise. Where pipes IO replaces lazy IO, 'Producer Text m r' replaces lazy 'Text'.+ An 'IO.Handle' can be associated with a 'Producer' or 'Consumer' according as it is read or written to.++ To stream to or from 'IO.Handle's, one can use 'fromHandle' or 'toHandle'. For+ example, the following program copies a document from one file to another:++> import Pipes+> import qualified Data.Text.Pipes as Text+> import System.IO+>+> main =+> withFile "inFile.txt" ReadMode $ \hIn ->+> withFile "outFile.txt" WriteMode $ \hOut ->+> runEffect $ Text.fromHandle hIn >-> Text.toHandle hOut++To stream from files, the following is perhaps more Prelude-like (note that it uses Pipes.Safe):++> import Pipes+> import qualified Data.Text.Pipes as Text+> import Pipes.Safe+>+> main = runSafeT $ runEffect $ Text.readFile "inFile.txt" >-> Text.writeFile "outFile.txt"++ You can stream to and from 'stdin' and 'stdout' using the predefined 'stdin'+ and 'stdout' proxies, as with the following \"echo\" program:++> main = runEffect $ Text.stdin >-> Text.stdout++ You can also translate pure lazy 'TL.Text's to and from proxies:++> main = runEffect $ Text.fromLazy (TL.pack "Hello, world!\n") >-> Text.stdout++ In addition, this module provides many functions equivalent to lazy+ 'Text' functions so that you can transform or fold text streams. For+ example, to stream only the first three lines of 'stdin' to 'stdout' you+ might write:++> import Pipes+> import qualified Pipes.Text as Text+> import qualified Pipes.Parse as Parse+>+> main = runEffect $ takeLines 3 Text.stdin >-> Text.stdout+> where+> takeLines n = Text.unlines . Parse.takeFree n . Text.lines++ The above program will never bring more than one chunk of text (~ 32 KB) into+ memory, no matter how long the lines are.++ Note that functions in this library are designed to operate on streams that+ are insensitive to text boundaries. This means that they may freely split+ text into smaller texts, /discard empty texts/. However, apart from the + special case of 'concatMap', they will /never concatenate texts/ in order + to provide strict upper bounds on memory usage -- with the single exception of 'concatMap'. +-}++module Pipes.Text (+ -- * Producers+ fromLazy+ , stdin+ , fromHandle+ , readFile+ , stdinLn++ -- * Consumers+ , stdout+ , stdoutLn+ , toHandle+ , writeFile++ -- * Pipes+ , map+ , concatMap+ , take+ , drop+ , takeWhile+ , dropWhile+ , filter+ , scan+ , encodeUtf8+ , pack+ , unpack+ , toCaseFold+ , toLower+ , toUpper+ , stripStart++ -- * Folds+ , toLazy+ , toLazyM+ , foldChars+ , head+ , last+ , null+ , length+ , any+ , all+ , maximum+ , minimum+ , find+ , index+ , count++ -- * Primitive Character Parsers+ -- $parse+ , nextChar+ , drawChar+ , unDrawChar+ , peekChar+ , isEndOfChars++ -- * Parsing Lenses + , splitAt+ , span+ , break+ , groupBy+ , group+ , word+ , line+ + -- * Decoding Lenses + , decodeUtf8+ , codec+ + -- * Codecs+ , utf8+ , utf16_le+ , utf16_be+ , utf32_le+ , utf32_be+ + -- * Other Decoding/Encoding Functions+ , decodeIso8859_1+ , decodeAscii+ , encodeIso8859_1+ , encodeAscii++ -- * FreeT Splitters+ , chunksOf+ , splitsWith+ , splits+-- , groupsBy+-- , groups+ , lines+ , words++ -- * Transformations+ , intersperse+ , packChars+ + -- * Joiners+ , intercalate+ , unlines+ , unwords++ -- * Re-exports+ -- $reexports+ , module Data.ByteString+ , module Data.Text+ , module Data.Profunctor+ , module Data.Word+ , module Pipes.Parse+ , module Pipes.Group+ , module Pipes.Text.Internal.Codec+ ) 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 Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TE+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.IO as TL+import Data.Text.Lazy.Internal (foldrChunks, defaultChunkSize)+import Data.ByteString.Unsafe (unsafeTake, unsafeDrop)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import Data.Char (ord, isSpace)+import Data.Functor.Constant (Constant(Constant, getConstant))+import Data.Functor.Identity (Identity)+import Data.Profunctor (Profunctor)+import qualified Data.Profunctor+import qualified Data.List as List+import Foreign.C.Error (Errno(Errno), ePIPE)+import qualified GHC.IO.Exception as G+import Pipes+import qualified Pipes.ByteString as PB+import qualified Pipes.Text.Internal.Decoding as PE+import Pipes.Text.Internal.Codec +import Pipes.Core (respond, Server')+import Pipes.Group (concats, intercalates, FreeT(..), FreeF(..))+import qualified Pipes.Group as PG+import qualified Pipes.Parse as PP+import Pipes.Parse (Parser)+import qualified Pipes.Safe.Prelude as Safe+import qualified Pipes.Safe as Safe+import Pipes.Safe (MonadSafe(..), Base(..))+import qualified Pipes.Prelude as P+import qualified System.IO as IO+import Data.Char (isSpace)+import Data.Word (Word8)++import Prelude hiding (+ all,+ any,+ break,+ concat,+ concatMap,+ drop,+ dropWhile,+ elem,+ filter,+ head,+ last,+ lines,+ length,+ map,+ maximum,+ minimum,+ notElem,+ null,+ readFile,+ span,+ splitAt,+ take,+ takeWhile,+ unlines,+ unwords,+ words,+ writeFile )++-- | Convert a lazy 'TL.Text' into a 'Producer' of strict 'Text's+fromLazy :: (Monad m) => TL.Text -> Producer' Text m ()+fromLazy = foldrChunks (\e a -> yield e >> a) (return ()) +{-# INLINE fromLazy #-}++-- | Stream text from 'stdin'+stdin :: MonadIO m => Producer Text m ()+stdin = fromHandle IO.stdin+{-# INLINE stdin #-}++{-| Convert a 'IO.Handle' into a text stream using a text size + determined by the good sense of the text library; note that this+ is distinctly slower than @decideUtf8 (Pipes.ByteString.fromHandle h)@+ but uses the system encoding and has other `Data.Text.IO` features+-}++fromHandle :: MonadIO m => IO.Handle -> Producer Text m ()+fromHandle h = go where+ go = do txt <- liftIO (T.hGetChunk h)+ unless (T.null txt) ( do yield txt+ go )+{-# INLINABLE fromHandle#-}+++{-| Stream text from a file in the simple fashion of @Data.Text.IO@ ++>>> runSafeT $ runEffect $ Text.readFile "hello.hs" >-> Text.map toUpper >-> hoist lift Text.stdout+MAIN = PUTSTRLN "HELLO WORLD"+-}++readFile :: MonadSafe m => FilePath -> Producer Text m ()+readFile file = Safe.withFile file IO.ReadMode fromHandle+{-# INLINE readFile #-}++{-| Crudely stream lines of input from stdin in the style of Pipes.Prelude. + This is for testing in ghci etc.; obviously it will be unsound if used to recieve+ the contents of immense files with few newlines.++>>> let safely = runSafeT . runEffect+>>> safely $ for Text.stdinLn (lift . lift . print . T.length)+hello+5+world+5++-}+stdinLn :: MonadIO m => Producer' Text m ()+stdinLn = go where+ go = do+ eof <- liftIO (IO.hIsEOF IO.stdin)+ unless eof $ do+ txt <- liftIO (T.hGetLine IO.stdin)+ yield txt+ go+{-# INLINABLE stdinLn #-}++{-| Stream text to 'stdout'++ Unlike 'toHandle', 'stdout' gracefully terminates on a broken output pipe.++ Note: For best performance, it might be best just to use @(for source (liftIO . putStr))@ + instead of @(source >-> stdout)@ .+-}+stdout :: MonadIO m => Consumer' Text m ()+stdout = go+ where+ go = do+ txt <- await+ x <- liftIO $ try (T.putStr txt)+ case x of+ Left (G.IOError { G.ioe_type = G.ResourceVanished+ , G.ioe_errno = Just ioe })+ | Errno ioe == ePIPE+ -> return ()+ Left e -> liftIO (throwIO e)+ Right () -> go+{-# INLINABLE stdout #-}++stdoutLn :: (MonadIO m) => Consumer' Text m ()+stdoutLn = go+ where+ go = do+ str <- await+ x <- liftIO $ try (T.putStrLn str)+ case x of+ Left (G.IOError { G.ioe_type = G.ResourceVanished+ , G.ioe_errno = Just ioe })+ | Errno ioe == ePIPE+ -> return ()+ Left e -> liftIO (throwIO e)+ Right () -> go+{-# INLINABLE stdoutLn #-}++{-| Convert a text stream into a 'Handle'++ Note: again, for best performance, where possible use + @(for source (liftIO . hPutStr handle))@ instead of @(source >-> toHandle handle)@.+-}+toHandle :: MonadIO m => IO.Handle -> Consumer' Text m r+toHandle h = for cat (liftIO . T.hPutStr h)+{-# INLINABLE toHandle #-}++{-# RULES "p >-> toHandle h" forall p h .+ p >-> toHandle h = for p (\txt -> liftIO (T.hPutStr h txt))+ #-}+++-- | Stream text into a file. Uses @pipes-safe@.+writeFile :: (MonadSafe m) => FilePath -> Consumer' Text m ()+writeFile file = Safe.withFile file IO.WriteMode toHandle+{-# INLINE writeFile #-}+++type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)++type Iso' a b = forall f p . (Functor f, Profunctor p) => p b (f b) -> p a (f a)++(^.) :: a -> ((b -> Constant b b) -> (a -> Constant b a)) -> b+a ^. lens = getConstant (lens Constant a)+++-- | Apply a transformation to each 'Char' in the stream+map :: (Monad m) => (Char -> Char) -> Pipe Text Text m r+map f = P.map (T.map f)+{-# INLINABLE map #-}++{-# RULES "p >-> map f" forall p f .+ p >-> map f = for p (\txt -> yield (T.map f txt))+ #-}++-- | Map a function over the characters of a text stream and concatenate the results+concatMap+ :: (Monad m) => (Char -> Text) -> Pipe Text Text m r+concatMap f = P.map (T.concatMap f)+{-# INLINABLE concatMap #-}++{-# RULES "p >-> concatMap f" forall p f .+ p >-> concatMap f = for p (\txt -> yield (T.concatMap f txt))+ #-}++-- | Transform a Pipe of 'Text' into a Pipe of 'ByteString's using UTF-8+-- encoding; @encodeUtf8 = Pipes.Prelude.map TE.encodeUtf8@ so more complex+-- encoding pipes can easily be constructed with the functions in @Data.Text.Encoding@+encodeUtf8 :: Monad m => Pipe Text ByteString m r+encodeUtf8 = P.map TE.encodeUtf8+{-# INLINEABLE encodeUtf8 #-}++{-# RULES "p >-> encodeUtf8" forall p .+ p >-> encodeUtf8 = for p (\txt -> yield (TE.encodeUtf8 txt))+ #-}++-- | Transform a Pipe of 'String's into one of 'Text' chunks+pack :: Monad m => Pipe String Text m r+pack = P.map T.pack+{-# INLINEABLE pack #-}++{-# RULES "p >-> pack" forall p .+ p >-> pack = for p (\txt -> yield (T.pack txt))+ #-}++-- | Transform a Pipes of 'Text' chunks into one of 'String's+unpack :: Monad m => Pipe Text String m r+unpack = for cat (\t -> yield (T.unpack t))+{-# INLINEABLE unpack #-}++{-# RULES "p >-> unpack" forall p .+ p >-> unpack = for p (\txt -> yield (T.unpack txt))+ #-}++-- | @toCaseFold@, @toLower@, @toUpper@ and @stripStart@ are standard 'Text' utilities, +-- here acting as 'Text' pipes, rather as they would on a lazy text+toCaseFold :: Monad m => Pipe Text Text m ()+toCaseFold = P.map T.toCaseFold+{-# INLINEABLE toCaseFold #-}++{-# RULES "p >-> toCaseFold" forall p .+ p >-> toCaseFold = for p (\txt -> yield (T.toCaseFold txt))+ #-}+++-- | lowercase incoming 'Text'+toLower :: Monad m => Pipe Text Text m ()+toLower = P.map T.toLower+{-# INLINEABLE toLower #-}++{-# RULES "p >-> toLower" forall p .+ p >-> toLower = for p (\txt -> yield (T.toLower txt))+ #-}++-- | uppercase incoming 'Text'+toUpper :: Monad m => Pipe Text Text m ()+toUpper = P.map T.toUpper+{-# INLINEABLE toUpper #-}++{-# RULES "p >-> toUpper" forall p .+ p >-> toUpper = for p (\txt -> yield (T.toUpper txt))+ #-}++-- | Remove leading white space from an incoming succession of 'Text's +stripStart :: Monad m => Pipe Text Text m r+stripStart = do+ chunk <- await+ let text = T.stripStart chunk+ if T.null text+ then stripStart+ else do yield text + cat+{-# INLINEABLE stripStart #-}++-- | @(take n)@ only allows @n@ individual characters to pass; +-- contrast @Pipes.Prelude.take@ which would let @n@ chunks pass.+take :: (Monad m, Integral a) => a -> Pipe Text Text 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 yield (T.take (fromIntegral n) txt)+ else do+ yield txt+ go (n - len)+{-# INLINABLE take #-}++-- | @(drop n)@ drops the first @n@ characters+drop :: (Monad m, Integral a) => a -> Pipe Text Text m r+drop n0 = go n0 where+ go n+ | n <= 0 = cat+ | otherwise = do+ txt <- await+ let len = fromIntegral (T.length txt)+ if (len >= n)+ then do+ yield (T.drop (fromIntegral n) txt)+ cat+ else go (n - len)+{-# INLINABLE drop #-}++-- | Take characters until they fail the predicate+takeWhile :: (Monad m) => (Char -> Bool) -> Pipe Text Text 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 yield prefix+{-# INLINABLE takeWhile #-}++-- | Drop characters until they fail the predicate+dropWhile :: (Monad m) => (Char -> Bool) -> Pipe Text Text m r+dropWhile predicate = go where+ go = do+ txt <- await+ case T.findIndex (not . predicate) txt of+ Nothing -> go+ Just i -> do+ yield (T.drop i txt)+ cat+{-# INLINABLE dropWhile #-}++-- | Only allows 'Char's to pass if they satisfy the predicate+filter :: (Monad m) => (Char -> Bool) -> Pipe Text Text m r+filter predicate = P.map (T.filter predicate)+{-# INLINABLE filter #-}++{-# RULES "p >-> filter q" forall p q .+ p >-> filter q = for p (\txt -> yield (T.filter q txt))+ #-}+ +-- | Strict left scan over the characters+scan+ :: (Monad m)+ => (Char -> Char -> Char) -> Char -> Pipe Text Text m r+scan step begin = go begin+ where+ go c = do+ txt <- await+ let txt' = T.scanl step c txt+ c' = T.last txt'+ yield txt'+ go c'+{-# INLINABLE scan #-}++{-| Fold a pure 'Producer' of strict 'Text's into a lazy+ 'TL.Text'+-}+toLazy :: Producer Text Identity () -> TL.Text+toLazy = TL.fromChunks . P.toList+{-# INLINABLE toLazy #-}++{-| Fold an effectful 'Producer' of strict 'Text's into a lazy+ 'TL.Text'++ Note: 'toLazyM' is not an idiomatic use of @pipes@, but I provide it for+ simple testing purposes. Idiomatic @pipes@ style consumes the chunks+ immediately as they are generated instead of loading them all into memory.+-}+toLazyM :: (Monad m) => Producer Text m () -> m TL.Text+toLazyM = liftM TL.fromChunks . P.toListM+{-# INLINABLE toLazyM #-}++-- | Reduce the text stream using a strict left fold over characters+foldChars+ :: Monad m+ => (x -> Char -> x) -> x -> (x -> r) -> Producer Text m () -> m r+foldChars step begin done = P.fold (T.foldl' step) begin done+{-# INLINABLE foldChars #-}++-- | Retrieve the first 'Char'+head :: (Monad m) => Producer Text m () -> m (Maybe Char)+head = go+ where+ go p = do+ x <- nextChar p+ case x of+ Left _ -> return Nothing+ Right (c, _) -> return (Just c)+{-# INLINABLE head #-}++-- | Retrieve the last 'Char'+last :: (Monad m) => Producer Text m () -> m (Maybe Char)+last = go Nothing+ where+ go r p = do+ x <- next p+ case x of+ Left () -> return r+ Right (txt, p') ->+ if (T.null txt)+ then go r p'+ else go (Just $ T.last txt) p'+{-# INLINABLE last #-}++-- | Determine if the stream is empty+null :: (Monad m) => Producer Text m () -> m Bool+null = P.all T.null+{-# INLINABLE null #-}++-- | Count the number of characters in the stream+length :: (Monad m, Num n) => Producer Text m () -> m n+length = P.fold (\n txt -> n + fromIntegral (T.length txt)) 0 id+{-# INLINABLE length #-}++-- | Fold that returns whether 'M.Any' received 'Char's satisfy the predicate+any :: (Monad m) => (Char -> Bool) -> Producer Text m () -> m Bool+any predicate = P.any (T.any predicate)+{-# INLINABLE any #-}++-- | Fold that returns whether 'M.All' received 'Char's satisfy the predicate+all :: (Monad m) => (Char -> Bool) -> Producer Text m () -> m Bool+all predicate = P.all (T.all predicate)+{-# INLINABLE all #-}++-- | Return the maximum 'Char' within a text stream+maximum :: (Monad m) => Producer Text m () -> m (Maybe Char)+maximum = P.fold step Nothing id+ where+ step mc txt =+ if (T.null txt)+ then mc+ else Just $ case mc of+ Nothing -> T.maximum txt+ Just c -> max c (T.maximum txt)+{-# INLINABLE maximum #-}++-- | Return the minimum 'Char' within a text stream (surely very useful!)+minimum :: (Monad m) => Producer Text m () -> m (Maybe Char)+minimum = P.fold step Nothing id+ where+ step mc txt =+ if (T.null txt)+ then mc+ else case mc of+ Nothing -> Just (T.minimum txt)+ Just c -> Just (min c (T.minimum txt))+{-# INLINABLE minimum #-}+++-- | Find the first element in the stream that matches the predicate+find+ :: (Monad m)+ => (Char -> Bool) -> Producer Text m () -> m (Maybe Char)+find predicate p = head (p >-> filter predicate)+{-# INLINABLE find #-}++-- | Index into a text stream+index+ :: (Monad m, Integral a)+ => a-> Producer Text m () -> m (Maybe Char)+index n p = head (p >-> drop n)+{-# INLINABLE index #-}+++-- | Store a tally of how many segments match the given 'Text'+count :: (Monad m, Num n) => Text -> Producer Text m () -> m n+count c p = P.fold (+) 0 id (p >-> P.map (fromIntegral . T.count c))+{-# INLINABLE count #-}+++{-| Consume the first character from a stream of 'Text'++ '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 a stream of 'Text', returning 'Left' if the+ 'Producer' is empty+-}+drawChar :: (Monad m) => Parser Text 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 -> Parser Text 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) => Parser Text 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@, which would consider+ an empty 'Text' a valid bit of input.++> isEndOfChars = liftM isLeft peekChar+-}+isEndOfChars :: (Monad m) => Parser Text m Bool+isEndOfChars = do+ x <- peekChar+ return (case x of+ Nothing -> True+ Just _-> False )+{-# INLINABLE isEndOfChars #-}+++-- | An improper lens into a stream of 'ByteString' expected to be UTF-8 encoded; the associated+-- stream of Text ends by returning a stream of ByteStrings beginning at the point of failure.++decodeUtf8 :: Monad m => Lens' (Producer ByteString m r) + (Producer Text m (Producer ByteString m r))+decodeUtf8 k p0 = fmap (\p -> join (for p (yield . TE.encodeUtf8))) + (k (go B.empty PE.streamDecodeUtf8 p0)) where+ go !carry dec0 p = do + x <- lift (next p) + case x of Left r -> return (if B.null carry + then return r -- all bytestring input was consumed+ else (do yield carry -- a potentially valid fragment remains+ return r))+ + Right (chunk, p') -> case dec0 chunk of + PE.Some text carry2 dec -> do yield text+ go carry2 dec p'+ PE.Other text bs -> do yield text + return (do yield bs -- an invalid blob remains+ p')+{-# INLINABLE decodeUtf8 #-}+++-- | Splits a 'Producer' after the given number of characters+splitAt+ :: (Monad m, Integral n)+ => n+ -> Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+splitAt n0 k p0 = fmap join (k (go n0 p0))+ where+ go 0 p = return p+ go n p = do+ x <- lift (next p)+ case x of+ Left r -> return (return r)+ Right (txt, p') -> do+ let len = fromIntegral (T.length txt)+ if (len <= n)+ then do+ yield txt+ go (n - len) p'+ else do+ let (prefix, suffix) = T.splitAt (fromIntegral n) txt+ yield prefix+ return (yield suffix >> p')+{-# INLINABLE splitAt #-}+++{-| Split a text stream in two, where the first text stream is the longest+ consecutive group of text that satisfy the predicate+-}+span+ :: (Monad m)+ => (Char -> Bool)+ -> Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+span predicate k p0 = fmap join (k (go p0))+ where+ go p = do+ x <- lift (next p)+ case x of+ Left r -> return (return r)+ Right (txt, p') -> do+ let (prefix, suffix) = T.span predicate txt+ if (T.null suffix)+ then do+ yield txt+ go p'+ else do+ yield prefix+ return (yield suffix >> p')+{-# INLINABLE span #-}++{-| Split a text stream in two, where the first text stream is the longest+ consecutive group of characters that don't satisfy the predicate+-}+break+ :: (Monad m)+ => (Char -> Bool)+ -> Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+break predicate = span (not . predicate)+{-# INLINABLE break #-}++{-| Improper lens that splits after the first group of equivalent Chars, as+ defined by the given equivalence relation+-}+groupBy+ :: (Monad m)+ => (Char -> Char -> Bool)+ -> Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+groupBy equals k p0 = fmap join (k ((go p0))) where+ go p = do+ x <- lift (next p)+ case x of+ Left r -> return (return r)+ Right (txt, p') -> case T.uncons txt of+ Nothing -> go p'+ Just (c, _) -> (yield txt >> p') ^. span (equals c) +{-# INLINABLE groupBy #-}++-- | Improper lens that splits after the first succession of identical 'Char' s+group :: Monad m + => Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+group = groupBy (==)+{-# INLINABLE group #-}++{-| Improper lens that splits a 'Producer' after the first word++ Unlike 'words', this does not drop leading whitespace +-}+word :: (Monad m) + => Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+word k p0 = fmap join (k (to p0))+ where+ to p = do+ p' <- p^.span isSpace+ p'^.break isSpace+{-# INLINABLE word #-}+++line :: (Monad m) + => Lens' (Producer Text m r)+ (Producer Text m (Producer Text m r))+line = break (== '\n')++{-# INLINABLE line #-}+++-- | Intersperse a 'Char' in between the characters of stream of 'Text'+intersperse+ :: (Monad m) => Char -> Producer Text m r -> Producer Text m r+intersperse c = go0+ where+ go0 p = do+ x <- lift (next p)+ case x of+ Left r -> return r+ Right (txt, p') -> do+ yield (T.intersperse c txt)+ go1 p'+ go1 p = do+ x <- lift (next p)+ case x of+ Left r -> return r+ Right (txt, p') -> do+ yield (T.singleton c)+ yield (T.intersperse c txt)+ go1 p'+{-# INLINABLE intersperse #-}++++-- | Improper isomorphism between a 'Producer' of 'ByteString's and 'Word8's+packChars :: Monad m => Iso' (Producer Char m x) (Producer Text m x)+packChars = Data.Profunctor.dimap to (fmap from)+ where+ -- to :: Monad m => Producer Char m x -> Producer Text m x+ to p = PG.folds step id done (p^.PG.chunksOf defaultChunkSize)++ step diffAs c = diffAs . (c:)++ done diffAs = T.pack (diffAs [])++ -- from :: Monad m => Producer Text m x -> Producer Char m x+ 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 -> Pure r+ Right (txt, p') -> Free $ do+ p'' <- (yield txt >> p') ^. splitAt n + return $ FreeT (go p'')+{-# INLINABLE chunksOf #-}+++{-| Split a text stream into sub-streams delimited by characters that satisfy the+ predicate+-}+splitsWith+ :: (Monad m)+ => (Char -> Bool)+ -> Producer Text m r+ -> FreeT (Producer Text m) m r+splitsWith predicate p0 = FreeT (go0 p0)+ where+ go0 p = do+ x <- next p+ case x of+ Left r -> return (Pure r)+ Right (txt, p') ->+ if (T.null txt)+ then go0 p'+ else return $ Free $ do+ p'' <- (yield txt >> p') ^. span (not . predicate)+ return $ FreeT (go1 p'')+ go1 p = do+ x <- nextChar p+ return $ case x of+ Left r -> Pure r+ Right (_, p') -> Free $ do+ p'' <- p' ^. span (not . predicate) + return $ FreeT (go1 p'')+{-# INLINABLE splitsWith #-}++-- | Split a text stream using the given 'Char' as the delimiter+splits :: (Monad m)+ => Char+ -> Lens' (Producer Text m r)+ (FreeT (Producer Text m) m r)+splits c k p =+ fmap (PG.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 (FreeT (go p0))) where + go p = do x <- next p+ case x of Left r -> return (Pure r)+ Right (bs, p') -> case T.uncons bs of+ Nothing -> go p'+ Just (c, _) -> do return $ Free $ do+ p'' <- (yield bs >> p')^.span (equals c)+ return $ 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) => Iso' (Producer Text m r) (FreeT (Producer Text m) m r)+lines = Data.Profunctor.dimap _lines (fmap _unlines)+ where+ _lines p0 = FreeT (go0 p0) + where+ go0 p = do+ x <- next p+ case x of+ Left r -> return (Pure r)+ Right (txt, p') ->+ if (T.null txt)+ then go0 p'+ else return $ Free $ go1 (yield txt >> p')+ go1 p = do+ p' <- p ^. break ('\n' ==)+ return $ FreeT $ do+ x <- nextChar p'+ case x of+ Left r -> return $ Pure r+ Right (_, p'') -> go0 p''+ -- _unlines+ -- :: Monad m+ -- => FreeT (Producer Text m) m x -> Producer Text m x+ _unlines = concats . PG.maps (<* yield (T.singleton '\n'))+ ++{-# INLINABLE lines #-}++++-- | Split a text stream into 'FreeT'-delimited words+words+ :: (Monad m) => Iso' (Producer Text m r) (FreeT (Producer Text m) m r)+words = Data.Profunctor.dimap go (fmap _unwords)+ where+ go p = FreeT $ do+ x <- next (p >-> dropWhile isSpace)+ return $ case x of+ Left r -> Pure r+ Right (bs, p') -> Free $ do+ p'' <- (yield bs >> p') ^. break isSpace+ return (go p'')+ _unwords = PG.intercalates (yield $ T.singleton ' ')+ +{-# INLINABLE words #-}+++{-| 'intercalate' concatenates the 'FreeT'-delimited text streams after+ interspersing a text stream in between them+-}+intercalate+ :: (Monad m)+ => Producer Text m ()+ -> FreeT (Producer Text m) m r+ -> Producer Text m r+intercalate p0 = go0+ where+ go0 f = do+ x <- lift (runFreeT f)+ case x of+ Pure r -> return r+ Free p -> do+ f' <- p+ go1 f'+ go1 f = do+ x <- lift (runFreeT f)+ case x of+ Pure r -> return r+ Free p -> do+ p0+ f' <- p+ go1 f'+{-# INLINABLE intercalate #-}++{-| Join 'FreeT'-delimited lines into a text stream+-}+unlines+ :: (Monad m) => FreeT (Producer Text m) m r -> Producer Text m r+unlines = go+ where+ go f = do+ x <- lift (runFreeT f)+ case x of+ Pure r -> return r+ Free p -> do+ f' <- p+ yield $ T.singleton '\n'+ go f'+{-# INLINABLE unlines #-}++{-| Join 'FreeT'-delimited words into a text stream+-}+unwords+ :: (Monad m) => FreeT (Producer Text m) m r -> Producer Text m r+unwords = intercalate (yield $ T.singleton ' ')+{-# INLINABLE unwords #-}++{- $parse+ The following parsing utilities are single-character analogs of the ones found+ @pipes-parse@.+-}++{- $reexports+ + @Data.Text@ re-exports the 'Text' type.++ @Pipes.Parse@ re-exports 'input', 'concat', 'FreeT' (the type) and the 'Parse' synonym. +-}++codec :: Monad m => Codec -> Lens' (Producer ByteString m r) (Producer Text m (Producer ByteString m r))+codec (Codec _ enc dec) k p0 = fmap (\p -> join (for p (yield . fst . enc))) + (k (decoder (dec B.empty) p0) ) where + decoder :: Monad m => PE.Decoding -> Producer ByteString m r -> Producer Text m (Producer ByteString m r)+ decoder !d p0 = case d of + PE.Other txt bad -> do yield txt+ return (do yield bad+ p0)+ PE.Some txt extra dec -> do yield txt+ x <- lift (next p0)+ case x of Left r -> return (do yield extra+ return r)+ Right (chunk,p1) -> decoder (dec chunk) p1++-- decodeUtf8 k p0 = fmap (\p -> join (for p (yield . TE.encodeUtf8))) +-- (k (go B.empty PE.streamDecodeUtf8 p0)) where++encodeAscii :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)+encodeAscii = go where+ go p = do echunk <- lift (next p)+ case echunk of + Left r -> return (return r)+ Right (chunk, p') -> + if T.null chunk + then go p'+ else let (safe, unsafe) = T.span (\c -> ord c <= 0x7F) chunk+ in do yield (B8.pack (T.unpack safe))+ if T.null unsafe+ then go p'+ else return $ do yield unsafe + p'++encodeIso8859_1 :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)+encodeIso8859_1 = go where+ go p = do etxt <- lift (next p)+ case etxt of + Left r -> return (return r)+ Right (txt, p') -> + if T.null txt + then go p'+ else let (safe, unsafe) = T.span (\c -> ord c <= 0xFF) txt+ in do yield (B8.pack (T.unpack safe))+ if T.null unsafe+ then go p'+ else return $ do yield unsafe + p'++decodeAscii :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)+decodeAscii = go where+ go p = do echunk <- lift (next p)+ case echunk of + Left r -> return (return r)+ Right (chunk, p') -> + if B.null chunk + then go p'+ else let (safe, unsafe) = B.span (<= 0x7F) chunk+ in do yield (T.pack (B8.unpack safe))+ if B.null unsafe+ then go p'+ else return $ do yield unsafe + p'+++decodeIso8859_1 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)+decodeIso8859_1 = go where+ go p = do echunk <- lift (next p)+ case echunk of + Left r -> return (return r)+ Right (chunk, p') -> + if B.null chunk + then go p'+ else let (safe, unsafe) = B.span (<= 0xFF) chunk+ in do yield (T.pack (B8.unpack safe))+ if B.null unsafe+ then go p'+ else return $ do yield unsafe + p'++++{-+ ascii :: Codec+ ascii = Codec name enc (toDecoding dec) where+ name = T.pack "ASCII"+ enc text = (bytes, extra) where+ (safe, unsafe) = T.span (\c -> ord c <= 0x7F) text+ bytes = B8.pack (T.unpack safe)+ extra = if T.null unsafe+ then Nothing+ else Just (EncodeException ascii (T.head unsafe), unsafe)++ dec bytes = (text, extra) where+ (safe, unsafe) = B.span (<= 0x7F) bytes+ text = T.pack (B8.unpack safe)+ extra = if B.null unsafe+ then Right B.empty+ else Left (DecodeException ascii (B.head unsafe), unsafe)++ iso8859_1 :: Codec+ iso8859_1 = Codec name enc (toDecoding dec) where+ name = T.pack "ISO-8859-1"+ enc text = (bytes, extra) where+ (safe, unsafe) = T.span (\c -> ord c <= 0xFF) text+ bytes = B8.pack (T.unpack safe)+ extra = if T.null unsafe+ then Nothing+ else Just (EncodeException iso8859_1 (T.head unsafe), unsafe)++ dec bytes = (T.pack (B8.unpack bytes), Right B.empty)+-}+
+ Pipes/Text/Internal/Codec.hs view
@@ -0,0 +1,215 @@++{-# LANGUAGE DeriveDataTypeable, RankNTypes, BangPatterns #-}+-- |+-- Copyright: 2014 Michael Thompson, 2011 Michael Snoyman, 2010-2011 John Millikin+-- License: MIT+--+-- Parts of this code were taken from enumerator and conduits, and adapted for pipes.++module Pipes.Text.Internal.Codec+ ( Decoding(..)+ , streamDecodeUtf8+ , decodeSomeUtf8+ , Codec(..)+ , TextException(..)+ , utf8+ , utf16_le+ , utf16_be+ , utf32_le+ , utf32_be+ ) where++import Data.Bits ((.&.))+import Data.Char (ord)+import Data.ByteString as B +import Data.ByteString (ByteString)+import Data.ByteString.Internal as B +import Data.ByteString.Char8 as B8+import Data.Text (Text)+import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error ()+import GHC.Word (Word8, Word32)+import qualified Data.Text.Array as A+import Data.Word (Word8, Word16)+import System.IO.Unsafe (unsafePerformIO)+import qualified Control.Exception as Exc+import Data.Bits ((.&.), (.|.), shiftL)+import Data.Typeable+import Control.Arrow (first)+import Data.Maybe (catMaybes)+import Pipes.Text.Internal.Decoding+import Pipes+-- | A specific character encoding.+--+-- Since 0.3.0+data Codec = Codec+ { codecName :: Text+ , codecEncode :: Text -> (ByteString, Maybe (TextException, Text))+ , codecDecode :: ByteString -> Decoding -- (Text, Either (TextException, ByteString) ByteString)+ }++instance Show Codec where+ showsPrec d c = showParen (d > 10) $ + showString "Codec " . shows (codecName c)++data TextException = DecodeException Codec Word8+ | EncodeException Codec Char+ | LengthExceeded Int+ | TextException Exc.SomeException+ deriving (Show, Typeable)+instance Exc.Exception TextException+++toDecoding :: (ByteString -> (Text, Either (TextException, ByteString) ByteString))+ -> (ByteString -> Decoding)+toDecoding op = loop B.empty where+ loop !extra bs0 = case op (B.append extra bs0) of+ (txt, Right bs) -> Some txt bs (loop bs)+ (txt, Left (_,bs)) -> Other txt bs+-- To do: toDecoding should be inlined in each of the 'Codec' definitions+-- or else Codec changed to the conduit/enumerator definition. We have+-- altered it to use 'streamDecodeUtf8'++splitSlowly :: (ByteString -> Text)+ -> ByteString + -> (Text, Either (TextException, ByteString) ByteString)+splitSlowly dec bytes = valid where+ valid:_ = catMaybes $ Prelude.map decFirst $ splits (B.length bytes)+ splits 0 = [(B.empty, bytes)]+ splits n = B.splitAt n bytes : splits (n - 1)+ decFirst (a, b) = case tryEvaluate (dec a) of+ Left _ -> Nothing+ Right text -> let trouble = case tryEvaluate (dec b) of+ Left exc -> Left (TextException exc, b)+ Right _ -> Right B.empty + in Just (text, trouble) -- this case shouldn't occur, + -- since splitSlowly is only called+ -- when parsing failed somewhere++utf8 :: Codec+utf8 = Codec name enc (toDecoding dec) where+ name = T.pack "UTF-8"+ enc text = (TE.encodeUtf8 text, Nothing)+ dec bytes = case decodeSomeUtf8 bytes of (t,b) -> (t, Right b)++-- -- Whether the given byte is a continuation byte.+-- isContinuation byte = byte .&. 0xC0 == 0x80+-- +-- -- The number of continuation bytes needed by the given+-- -- non-continuation byte. Returns -1 for an illegal UTF-8+-- -- non-continuation byte and the whole split quickly must fail so+-- -- as the input is passed to TE.decodeUtf8, which will issue a+-- -- suitable error.+-- required x0+-- | x0 .&. 0x80 == 0x00 = 0+-- | x0 .&. 0xE0 == 0xC0 = 1+-- | x0 .&. 0xF0 == 0xE0 = 2+-- | x0 .&. 0xF8 == 0xF0 = 3+-- | otherwise = -1+-- +-- splitQuickly bytes+-- | B.null l || req == -1 = Nothing+-- | req == B.length r = Just (TE.decodeUtf8 bytes, B.empty)+-- | otherwise = Just (TE.decodeUtf8 l', r')+-- where+-- (l, r) = B.spanEnd isContinuation bytes+-- req = required (B.last l)+-- l' = B.init l+-- r' = B.cons (B.last l) r+++utf16_le :: Codec+utf16_le = Codec name enc (toDecoding dec) where+ name = T.pack "UTF-16-LE"+ enc text = (TE.encodeUtf16LE text, Nothing)+ dec bytes = case splitQuickly bytes of+ Just (text, extra) -> (text, Right extra)+ Nothing -> splitSlowly TE.decodeUtf16LE bytes++ splitQuickly bytes = maybeDecode (loop 0) where+ maxN = B.length bytes++ loop n | n == maxN = decodeAll+ | (n + 1) == maxN = decodeTo n+ loop n = let+ req = utf16Required+ (B.index bytes n)+ (B.index bytes (n + 1))+ decodeMore = loop $! n + req+ in if n + req > maxN+ then decodeTo n+ else decodeMore++ decodeTo n = first TE.decodeUtf16LE (B.splitAt n bytes)+ decodeAll = (TE.decodeUtf16LE bytes, B.empty)++utf16_be :: Codec+utf16_be = Codec name enc (toDecoding dec) where+ name = T.pack "UTF-16-BE"+ enc text = (TE.encodeUtf16BE text, Nothing)+ dec bytes = case splitQuickly bytes of+ Just (text, extra) -> (text, Right extra)+ Nothing -> splitSlowly TE.decodeUtf16BE bytes++ splitQuickly bytes = maybeDecode (loop 0) where+ maxN = B.length bytes++ loop n | n == maxN = decodeAll+ | (n + 1) == maxN = decodeTo n+ loop n = let+ req = utf16Required+ (B.index bytes (n + 1))+ (B.index bytes n)+ decodeMore = loop $! n + req+ in if n + req > maxN+ then decodeTo n+ else decodeMore++ decodeTo n = first TE.decodeUtf16BE (B.splitAt n bytes)+ decodeAll = (TE.decodeUtf16BE bytes, B.empty)++utf16Required :: Word8 -> Word8 -> Int+utf16Required x0 x1 = if x >= 0xD800 && x <= 0xDBFF then 4 else 2 where+ x :: Word16+ x = (fromIntegral x1 `shiftL` 8) .|. fromIntegral x0+++utf32_le :: Codec+utf32_le = Codec name enc (toDecoding dec) where+ name = T.pack "UTF-32-LE"+ enc text = (TE.encodeUtf32LE text, Nothing)+ dec bs = case utf32SplitBytes TE.decodeUtf32LE bs of+ Just (text, extra) -> (text, Right extra)+ Nothing -> splitSlowly TE.decodeUtf32LE bs+++utf32_be :: Codec+utf32_be = Codec name enc (toDecoding dec) where+ name = T.pack "UTF-32-BE"+ enc text = (TE.encodeUtf32BE text, Nothing)+ dec bs = case utf32SplitBytes TE.decodeUtf32BE bs of+ Just (text, extra) -> (text, Right extra)+ Nothing -> splitSlowly TE.decodeUtf32BE bs++utf32SplitBytes :: (ByteString -> Text)+ -> ByteString+ -> Maybe (Text, ByteString)+utf32SplitBytes dec bytes = split where+ split = maybeDecode (dec toDecode, extra)+ len = B.length bytes+ lenExtra = mod len 4++ lenToDecode = len - lenExtra+ (toDecode, extra) = if lenExtra == 0+ then (bytes, B.empty)+ else B.splitAt lenToDecode bytes+++tryEvaluate :: a -> Either Exc.SomeException a+tryEvaluate = unsafePerformIO . Exc.try . Exc.evaluate++maybeDecode :: (a, b) -> Maybe (a, b)+maybeDecode (a, b) = case tryEvaluate a of+ Left _ -> Nothing+ Right _ -> Just (a, b)
+ Pipes/Text/Internal/Decoding.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MagicHash, UnliftedFFITypes #-}+{-# LANGUAGE DeriveDataTypeable, RankNTypes #-}++-- This module lifts assorted materials from Brian O'Sullivan's text package +-- especially Data.Text.Encoding in order to define a pipes-appropriate+-- streamDecodeUtf8+module Pipes.Text.Internal.Decoding + ( Decoding(..)+ , streamDecodeUtf8+ , decodeSomeUtf8+ ) where+import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO)+import Control.Monad.ST (ST, runST)+import Data.Bits ((.&.))+import Data.ByteString as B +import Data.ByteString (ByteString)+import Data.ByteString.Internal as B +import Data.ByteString.Char8 as B8+import Data.Text (Text)+import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Encoding.Error ()+import Data.Text.Internal (Text, textP)+import Foreign.C.Types (CSize)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)+import Foreign.Storable (Storable, peek, poke)+import GHC.Base (Char(..), Int(..), MutableByteArray#, ord#, iShiftRA#)+import GHC.Word (Word8, Word32)+import qualified Data.Text.Array as A+import Data.Word (Word8, Word16)+import System.IO.Unsafe (unsafePerformIO)+import qualified Control.Exception as Exc+import Data.Bits ((.&.), (.|.), shiftL)+import Data.Typeable+import Control.Arrow (first)+import Data.Maybe (catMaybes)+#include "pipes_text_cbits.h"++++-- | A stream oriented decoding result.+data Decoding = Some Text ByteString (ByteString -> Decoding)+ | Other Text ByteString+instance Show Decoding where+ showsPrec d (Some t bs _) = showParen (d > prec) $+ showString "Some " . showsPrec prec' t .+ showChar ' ' . showsPrec prec' bs .+ showString " _"+ where prec = 10; prec' = prec + 1+ showsPrec d (Other t bs) = showParen (d > prec) $+ showString "Other " . showsPrec prec' t .+ showChar ' ' . showsPrec prec' bs .+ showString " _"+ where prec = 10; prec' = prec + 1++newtype CodePoint = CodePoint Word32 deriving (Eq, Show, Num, Storable)+newtype DecoderState = DecoderState Word32 deriving (Eq, Show, Num, Storable)++streamDecodeUtf8 :: ByteString -> Decoding+streamDecodeUtf8 = decodeChunkUtf8 B.empty 0 0 + where+ decodeChunkUtf8 :: ByteString -> CodePoint -> DecoderState -> ByteString -> Decoding+ decodeChunkUtf8 old codepoint0 state0 bs@(PS fp off len) = + runST $ do marray <- A.new (len+1) + unsafeIOToST (decodeChunkToBuffer marray)+ where+ decodeChunkToBuffer :: A.MArray s -> IO Decoding+ decodeChunkToBuffer dest = withForeignPtr fp $ \ptr ->+ with (0::CSize) $ \destOffPtr ->+ with codepoint0 $ \codepointPtr ->+ with state0 $ \statePtr ->+ with nullPtr $ \curPtrPtr ->+ do let end = ptr `plusPtr` (off + len)+ curPtr = ptr `plusPtr` off+ poke curPtrPtr curPtr+ c_decode_utf8_with_state (A.maBA dest) destOffPtr curPtrPtr end codepointPtr statePtr+ state <- peek statePtr+ lastPtr <- peek curPtrPtr+ codepoint <- peek codepointPtr+ n <- peek destOffPtr+ chunkText <- mkText dest n+ let left = lastPtr `minusPtr` curPtr+ remaining = B.drop left bs+ accum = if T.null chunkText then B.append old remaining else remaining + return $! case state of + UTF8_REJECT -> Other chunkText accum -- We encountered an encoding error+ _ -> Some chunkText accum (decodeChunkUtf8 accum codepoint state)+ {-# INLINE decodeChunkToBuffer #-}+ {-# INLINE decodeChunkUtf8 #-}+{-# INLINE streamDecodeUtf8 #-}++decodeSomeUtf8 :: ByteString -> (Text, ByteString)+decodeSomeUtf8 bs@(PS fp off len) = runST $ do + dest <- A.new (len+1) + unsafeIOToST $ + withForeignPtr fp $ \ptr ->+ with (0::CSize) $ \destOffPtr ->+ with (0::CodePoint) $ \codepointPtr ->+ with (0::DecoderState) $ \statePtr ->+ with nullPtr $ \curPtrPtr ->+ do let end = ptr `plusPtr` (off + len)+ curPtr = ptr `plusPtr` off+ poke curPtrPtr curPtr+ c_decode_utf8_with_state (A.maBA dest) destOffPtr + curPtrPtr end codepointPtr statePtr+ state <- peek statePtr+ lastPtr <- peek curPtrPtr+ codepoint <- peek codepointPtr+ n <- peek destOffPtr+ chunkText <- unsafeSTToIO $ do arr <- A.unsafeFreeze dest+ return $! textP arr 0 (fromIntegral n)+ let left = lastPtr `minusPtr` curPtr+ remaining = B.drop left bs+ return $! (chunkText, remaining)+{-# INLINE decodeSomeUtf8 #-}++mkText :: A.MArray s -> CSize -> IO Text+mkText dest n = unsafeSTToIO $ do arr <- A.unsafeFreeze dest+ return $! textP arr 0 (fromIntegral n)+{-# INLINE mkText #-}++ord :: Char -> Int+ord (C# c#) = I# (ord# c#)+{-# INLINE ord #-}++unsafeWrite :: A.MArray s -> Int -> Char -> ST s Int+unsafeWrite marr i c+ | n < 0x10000 = do A.unsafeWrite marr i (fromIntegral n)+ return 1+ | otherwise = do A.unsafeWrite marr i lo+ A.unsafeWrite marr (i+1) hi+ return 2+ where n = ord c+ m = n - 0x10000+ lo = fromIntegral $ (m `shiftR` 10) + 0xD800+ hi = fromIntegral $ (m .&. 0x3FF) + 0xDC00+ shiftR (I# x#) (I# i#) = I# (x# `iShiftRA#` i#)+ {-# INLINE shiftR #-}+{-# INLINE unsafeWrite #-}++foreign import ccall unsafe "_hs_pipes_text_decode_utf8_state" c_decode_utf8_with_state+ :: MutableByteArray# s -> Ptr CSize+ -> Ptr (Ptr Word8) -> Ptr Word8+ -> Ptr CodePoint -> Ptr DecoderState -> IO (Ptr Word8)
+ README.md view
@@ -0,0 +1,17 @@+text-pipes+==========++This repo is called `text-pipes`, but the package is named `pipes-text` as one might expect. +The two modules it contatins, `Pipes.Text` and `Pipes.Text.Parse`, use materials from [`pipes-text`](https://github.com/ibotty/pipes-text); +otherwise they follow the pattern of [`pipes-bytestring`](https://github.com/Gabriel439/Haskell-Pipes-ByteString-Library), adding a few `pipes-prelude`-like operations.+The most important function, `decodeUtf8`, written by ibotty, uses the development version of the text package; this package can however be built with the hackage `text` +though `decodeUtf8` will then not exist.++ >>> runEffect $ stdinLn >-> P.takeWhile (/= "quit") >-> stdoutLn+ hi<Return>+ hi+ quit<Return>+ >>> runSafeT $ runEffect $ readFile "README.md" >-> toUpper >-> hoist lift stdout+ TEXT-PIPES+ ==========+ ...
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/cbits.c view
@@ -0,0 +1,168 @@+/*+ * Copyright (c) 2011 Bryan O'Sullivan <bos@serpentine.com>.+ *+ * Portions copyright (c) 2008-2010 Björn Höhrmann <bjoern@hoehrmann.de>.+ *+ * See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details.+ */++#include <string.h>+#include <stdint.h>+#include <stdio.h>+#include "pipes_text_cbits.h"++++#define UTF8_ACCEPT 0+#define UTF8_REJECT 12++static const uint8_t utf8d[] = {+ /*+ * The first part of the table maps bytes to character classes that+ * to reduce the size of the transition table and create bitmasks.+ */+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,+ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,+ 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,+ 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8,++ /*+ * The second part is a transition table that maps a combination of+ * a state of the automaton and a character class to a state.+ */+ 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12,+ 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12,+ 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12,+ 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12,+ 12,36,12,12,12,12,12,12,12,12,12,12,+};++static inline uint32_t+decode(uint32_t *state, uint32_t* codep, uint32_t byte) {+ uint32_t type = utf8d[byte];++ *codep = (*state != UTF8_ACCEPT) ?+ (byte & 0x3fu) | (*codep << 6) :+ (0xff >> type) & (byte);++ return *state = utf8d[256 + *state + type];+}++/*+ * A best-effort decoder. Runs until it hits either end of input or+ * the start of an invalid byte sequence.+ *+ * At exit, we update *destoff with the next offset to write to, *src+ * with the next source location past the last one successfully+ * decoded, and return the next source location to read from.+ *+ * Moreover, we expose the internal decoder state (state0 and+ * codepoint0), allowing one to restart the decoder after it+ * terminates (say, due to a partial codepoint).+ *+ * In particular, there are a few possible outcomes,+ *+ * 1) We decoded the buffer entirely:+ * In this case we return srcend+ * state0 == UTF8_ACCEPT+ *+ * 2) We met an invalid encoding+ * In this case we return the address of the first invalid byte+ * state0 == UTF8_REJECT+ *+ * 3) We reached the end of the buffer while decoding a codepoint+ * In this case we return a pointer to the first byte of the partial codepoint+ * state0 != UTF8_ACCEPT, UTF8_REJECT+ *+ */++ #if defined(__GNUC__) || defined(__clang__)+ static inline uint8_t const *+ _hs_pipes_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,+ const uint8_t const **src, const uint8_t const *srcend,+ uint32_t *codepoint0, uint32_t *state0)+ __attribute((always_inline));+ #endif++static inline uint8_t const *+_hs_pipes_text_decode_utf8_int(uint16_t *const dest, size_t *destoff,+ const uint8_t const **src, const uint8_t const *srcend,+ uint32_t *codepoint0, uint32_t *state0)+{+ uint16_t *d = dest + *destoff;+ const uint8_t *s = *src, *last = *src;+ uint32_t state = *state0;+ uint32_t codepoint = *codepoint0;++ while (s < srcend) {+#if defined(__i386__) || defined(__x86_64__)+ /*+ * This code will only work on a little-endian system that+ * supports unaligned loads.+ *+ * It gives a substantial speed win on data that is purely or+ * partly ASCII (e.g. HTML), at only a slight cost on purely+ * non-ASCII text.+ */++ if (state == UTF8_ACCEPT) {+ while (s < srcend - 4) {+ codepoint = *((uint32_t *) s);+ if ((codepoint & 0x80808080) != 0)+ break;+ s += 4;++ /*+ * Tried 32-bit stores here, but the extra bit-twiddling+ * slowed the code down.+ */++ *d++ = (uint16_t) (codepoint & 0xff);+ *d++ = (uint16_t) ((codepoint >> 8) & 0xff);+ *d++ = (uint16_t) ((codepoint >> 16) & 0xff);+ *d++ = (uint16_t) ((codepoint >> 24) & 0xff);+ }+ last = s;+ }+#endif++ if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) {+ if (state != UTF8_REJECT)+ continue;+ break;+ }++ if (codepoint <= 0xffff)+ *d++ = (uint16_t) codepoint;+ else {+ *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10));+ *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF));+ }+ last = s;+ }++ *destoff = d - dest;+ *codepoint0 = codepoint;+ *state0 = state;+ *src = last;++ return s;+}++uint8_t const *+_hs_pipes_text_decode_utf8_state(uint16_t *const dest, size_t *destoff,+ const uint8_t const **src,+ const uint8_t const *srcend,+ uint32_t *codepoint0, uint32_t *state0)+{+ uint8_t const *ret = _hs_pipes_text_decode_utf8_int(dest, destoff, src, srcend,+ codepoint0, state0);+ if (*state0 == UTF8_REJECT)+ ret -=1;+ return ret;+}+
+ include/pipes_text_cbits.h view
@@ -0,0 +1,11 @@+/*+ * Copyright (c) 2013 Bryan O'Sullivan <bos@serpentine.com>.+ */++#ifndef _pipes_text_cbits_h+#define _pipes_text_cbits_h++#define UTF8_ACCEPT 0+#define UTF8_REJECT 12++#endif
+ pipes-text.cabal view
@@ -0,0 +1,52 @@+name: pipes-text+version: 0.0.0.0+synopsis: Text pipes.+description: Many of the pipes and other operations defined here mirror those in+ the `pipes-bytestring` library. Folds like `length` and grouping + operations like `lines` simply adjust for the differences between + `ByteString` and `Text` and `Word8` and `Char`. The distinctive feature+ of the library is the `Text/ByteString` encoding and decoding apparatus.+ .+ To this core are added some simple functions akin to the `String` + operations in `Pipes.Prelude`, and others like the utilities in `Data.Text`. + .+ All of the `IO` operations defined here - e.g `readFile`, `stdout` etc. + - are conveniences akin to those in `Data.Text.IO` which e.g. try to + find the system encoding and use the exceptions defined in the `text`+ library. Proper `IO` in the sense of this library will employ + `pipes-bytestring` in conjuntion with 'pure' operations like + `decodeUtf8` and `encodeUtf8` that are defined here. ++homepage: https://github.com/michaelt/text-pipes+bug-reports: https://github.com/michaelt/text-pipes/issues++license: BSD3+license-file: LICENSE+author: Michael Thompson+maintainer: what_is_it_to_do_anything@yahoo.com+category: Text, Pipes++build-type: Simple+cabal-version: >=1.10+extra-source-files: README.md+ include/*.h ++library+ c-sources: cbits/cbits.c+ include-dirs: include+ exposed-modules: Pipes.Text, Pipes.Text.Internal.Decoding, Pipes.Text.Internal.Codec+ -- other-modules: + other-extensions: RankNTypes+ build-depends: base >= 4 && < 5 ,+ bytestring >=0.10 && < 0.11,+ text >=0.11 && < 1.2,+ profunctors >= 3.1.1 && < 4.1 ,+ pipes >=4.0 && < 4.2,+ pipes-group >= 1.0.0 && < 1.1 ,+ pipes-parse >=2.0 && < 3.1,+ pipes-safe, + pipes-bytestring >= 1.0 && < 2.1,+ transformers >= 0.2.0.0 && < 0.4+ -- hs-source-dirs: + default-language: Haskell2010+ ghc-options: -O2