From 4cbc92cc93073d1a5b99a03ad802f710d0205994 Mon Sep 17 00:00:00 2001 From: michaelt Date: Tue, 4 Feb 2014 00:00:48 -0500 Subject: moved enumerator/conduit Codec business to its own module --- Pipes/Text.hs | 29 +++--- Pipes/Text/Codec.hs | 240 +++++++++++++++++++++++++++++++++++++++++++++++++ Pipes/Text/Internal.hs | 212 ------------------------------------------- pipes-text.cabal | 2 +- 4 files changed, 255 insertions(+), 228 deletions(-) create mode 100644 Pipes/Text/Codec.hs diff --git a/Pipes/Text.hs b/Pipes/Text.hs index 71b1316..9ed0d78 100644 --- a/Pipes/Text.hs +++ b/Pipes/Text.hs @@ -181,7 +181,7 @@ import qualified GHC.IO.Exception as G import Pipes import qualified Pipes.ByteString as PB import qualified Pipes.Text.Internal as PE -import Pipes.Text.Internal (Codec(..)) +import Pipes.Text.Codec (Codec(..)) import Pipes.Core (respond, Server') import Pipes.Group (concats, intercalates, FreeT(..), FreeF(..)) import qualified Pipes.Group as PG @@ -243,8 +243,8 @@ stdin = fromHandle IO.stdin 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 + unless (T.null txt) ( do yield txt + go ) {-# INLINABLE fromHandle#-} @@ -258,7 +258,9 @@ readFile :: MonadSafe m => FilePath -> Producer Text m () readFile file = Safe.withFile file IO.ReadMode fromHandle {-# INLINE readFile #-} -{-| Stream lines of text from stdin (for testing in ghci etc.) +{-| 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) @@ -282,8 +284,8 @@ stdinLn = go where Unlike 'toHandle', 'stdout' gracefully terminates on a broken output pipe. - Note: For best performance, use @(for source (liftIO . putStr))@ instead of - @(source >-> stdout)@ in suitable cases. + 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 @@ -704,11 +706,8 @@ isEndOfChars = do {-# INLINABLE isEndOfChars #-} - - - --- | Transform a Pipe of 'ByteString's expected to be UTF-8 encoded into a Pipe of Text --- returning a Pipe of ByteStrings that begins at the point of failure. +-- | 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)) @@ -716,10 +715,10 @@ 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 -> if B.null carry - then return (return r) -- all bytestrinput was consumed - else return (do yield carry -- a potentially valid fragment remains - return r) + 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 diff --git a/Pipes/Text/Codec.hs b/Pipes/Text/Codec.hs new file mode 100644 index 0000000..e4357b9 --- /dev/null +++ b/Pipes/Text/Codec.hs @@ -0,0 +1,240 @@ + +{-# LANGUAGE DeriveDataTypeable, RankNTypes #-} +-- | +-- Copyright: 2014 Michael Thompson, 2011 Michael Snoyman, 2010-2011 John Millikin +-- License: MIT +-- +-- Handle streams of text. +-- +-- Parts of this code were taken from enumerator and conduits, and adapted for pipes. + +module Pipes.Text.Codec + ( Decoding(..) + , streamDecodeUtf8 + , decodeSomeUtf8 + , Codec(..) + , TextException(..) + , utf8 + ) 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 + +-- | 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 + + +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 + +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) + +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) diff --git a/Pipes/Text/Internal.hs b/Pipes/Text/Internal.hs index 76c2f4f..bcee278 100644 --- a/Pipes/Text/Internal.hs +++ b/Pipes/Text/Internal.hs @@ -9,9 +9,6 @@ module Pipes.Text.Internal ( Decoding(..) , streamDecodeUtf8 , decodeSomeUtf8 - , Codec(..) - , TextException(..) - , utf8 ) where import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Control.Monad.ST (ST, runST) @@ -43,215 +40,6 @@ import Data.Maybe (catMaybes) #include "pipes_text_cbits.h" --- | 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) - --- Since 0.3.0 -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 - - -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 - --- | --- Since 0.3.0 -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) - --- | --- Since 0.3.0 -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 - --- | --- Since 0.3.0 -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 - --- | --- Since 0.3.0 -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 - --- | --- Since 0.3.0 -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) - --- | --- Since 0.3.0 -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) - -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) -- | A stream oriented decoding result. data Decoding = Some Text ByteString (ByteString -> Decoding) diff --git a/pipes-text.cabal b/pipes-text.cabal index 33cbab4..44bc551 100644 --- a/pipes-text.cabal +++ b/pipes-text.cabal @@ -14,7 +14,7 @@ cabal-version: >=1.10 library c-sources: cbits/cbits.c include-dirs: include - exposed-modules: Pipes.Text, Pipes.Text.Internal + exposed-modules: Pipes.Text, Pipes.Text.Internal, Pipes.Text.Codec -- other-modules: other-extensions: RankNTypes build-depends: base >= 4 && < 5 , -- cgit v1.2.3