Pipes/Text/Encoding.hs

   1 {-# LANGUAGE RankNTypes, BangPatterns #-}
   2
   3 -- | This module uses the stream decoding functions from
   4 --  <http://hackage.haskell.org/package/streaming-commons streaming-commons>
   5 --  package to define decoding functions and lenses.  The exported names
   6 --  conflict with names in @Data.Text.Encoding@ but not with the @Prelude@
   7
   8 module Pipes.Text.Encoding
   9     (
  10     -- * Decoding ByteStrings and Encoding Texts
  11     -- ** Simple usage
  12     -- $usage
  13
  14     -- ** Lens usage
  15     -- $lenses
  16
  17
  18     -- * Basic lens operations
  19     Codec
  20     , decode
  21     , eof
  22     -- * Decoding lenses
  23     , utf8
  24     , utf8Pure
  25     , utf16LE
  26     , utf16BE
  27     , utf32LE
  28     , utf32BE
  29     -- * Non-lens decoding functions
  30     -- $decoders
  31     , decodeUtf8
  32     , decodeUtf8Pure
  33     , decodeUtf16LE
  34     , decodeUtf16BE
  35     , decodeUtf32LE
  36     , decodeUtf32BE
  37     -- * Re-encoding functions
  38     -- $encoders
  39     , encodeUtf8
  40     , encodeUtf16LE
  41     , encodeUtf16BE
  42     , encodeUtf32LE
  43     , encodeUtf32BE
  44     -- * Functions for latin and ascii text
  45     -- $ascii
  46     , encodeAscii
  47     , decodeAscii
  48     , encodeIso8859_1
  49     , decodeIso8859_1
  50     )
  51     where
  52
  53 import Data.Functor.Constant (Constant(..))
  54 import Data.Char (ord)
  55 import Data.ByteString as B
  56 import Data.ByteString.Char8 as B8
  57 import Data.Text (Text)
  58 import qualified Data.Text as T
  59 import qualified Data.Text.Encoding as TE
  60 import qualified Data.Streaming.Text as Stream
  61 import Data.Streaming.Text (DecodeResult(..))
  62 import Control.Monad (join, liftM)
  63 import Pipes
  64
  65
  66
  67 {- $usage
  68     Given
  69
  70 >   text :: Producer Text IO ()
  71
  72     we can encode it with @Data.Text.Encoding@ and ordinary pipe operations:
  73
  74 >   text >-> P.map TE.encodeUtf8 :: Producer.ByteString IO ()
  75
  76     or, using this module, with
  77
  78 >   for text encodeUtf8 :: Producer.ByteString IO ()
  79
  80     Given
  81
  82 >   bytes :: Producer ByteString Text IO ()
  83
  84     we can apply a decoding function from this module:
  85
  86 >   decodeUtf8 bytes :: Producer Text IO (Producer ByteString IO ())
  87
  88     The Text producer ends wherever decoding first fails. Thus we can re-encode
  89     as uft8 as much of our byte stream as is decodeUtf16BE decodable, with, e.g.
  90
  91 >   for (decodeUtf16BE bytes) encodeUtf8 :: Producer ByteString IO (Producer ByteString IO ())
  92
  93     The bytestring producer that is returned begins with where utf16BE decoding
  94     failed; if it didn't fail the producer is empty.
  95
  96 -}
  97
  98 {- $lenses
  99     We get a bit more flexibility, though, if we use a lens like @utf8@ or @utf16BE@
 100     that looks for text in an appropriately encoded byte stream.
 101
 102 >   type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
 103
 104     is just an alias for a Prelude type.   We abbreviate this further, for our use case, as
 105
 106 >   type Codec
 107 >     =  forall m r .  Monad m => Lens' (Producer ByteString m r) (Producer Text m (Producer ByteString m r))
 108
 109     and call the decoding lenses @utf8@, @utf16BE@ \"codecs\", since they can
 110     re-encode what they have decoded.  Thus you use any particular codec with
 111     the @view@ / @(^.)@ , @zoom@ and @over@ functions from the standard lens libraries;
 112     we presuppose neither <http://hackage.haskell.org/package/lens lens>
 113     nor  <http://hackage.haskell.org/package/lens-family lens-family>
 114     since we already have access to the types they require.
 115
 116     Each decoding lens looks into a byte stream that is supposed to contain text.
 117     The particular lenses are named in accordance with the expected
 118     encoding, 'utf8', 'utf16LE' etc. To turn a such a lens or @Codec@
 119     into an ordinary function, use @view@ / @(^.)@ -- here also called 'decode':
 120
 121 >   view utf8 :: Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 122 >   decode utf8 Byte.stdin :: Producer Text IO (Producer ByteString IO r)
 123 >   Bytes.stdin ^. utf8 ::  Producer Text IO (Producer ByteString IO r)
 124
 125     These simple uses of a codec with @view@ or @(^.)@ or 'decode' can always be replaced by
 126     the specialized decoding functions exported here, e.g.
 127
 128 >   decodeUtf8 ::  Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 129 >   decodeUtf8 Byte.stdin :: Producer Text IO (Producer ByteString IO r)
 130
 131     As with these functions, the stream of text that a @Codec@ \'sees\'
 132     in the stream of bytes begins at its head.
 133     At any point of decoding failure, the stream of text ends and reverts to (returns)
 134     the original byte stream. Thus if the first bytes are already
 135     un-decodable, the whole ByteString producer will be returned, i.e.
 136
 137 >   view utf8 bad_bytestream
 138
 139     will just come to the same as
 140
 141 >   return bad_bytestream
 142
 143     Where there is no decoding failure, the return value of the text stream will be
 144     an empty byte stream followed by its own return value.  In all cases you must
 145     deal with the fact that it is a /ByteString producer/ that is returned, even if
 146     it can be thrown away with @Control.Monad.void@
 147
 148 >   void (Bytes.stdin ^. utf8) :: Producer Text IO ()
 149
 150     The @eof@ lens permits you to pattern match: if there is a Right value,
 151     it is the leftover bytestring producer, if there is a Right value, it
 152     is the return value of the original bytestring producer:
 153
 154 >   Bytes.stdin ^. utf8 . eof :: Producer Text IO (Either (Producer ByteString IO IO) ())
 155
 156     Thus for the stream of un-decodable bytes mentioned above,
 157
 158 >   view (utf8 . eof) bad_bytestream
 159
 160     will be the same as
 161
 162 >   return (Left bad_bytestream)
 163
 164     @zoom@ converts a Text parser into a ByteString parser:
 165
 166 >   zoom utf8 drawChar :: Monad m => StateT (Producer ByteString m r) m (Maybe Char)
 167
 168     or, using the type synonymn from @Pipes.Parse@:
 169
 170 >   zoom utf8 drawChar :: Monad m => Parser ByteString m (Maybe Char)
 171
 172     Thus we can define a ByteString parser (in the pipes-parse sense) like this:
 173
 174 >   charPlusByte :: Parser ByteString m (Maybe Char, Maybe Word8)))
 175 >   charPlusByte = do char_ <- zoom utf8 Text.drawChar
 176 >                     byte_ <- Bytes.peekByte
 177 >                     return (char_, byte_)
 178
 179      Though @charPlusByte@ is partly defined with a Text parser 'drawChar';
 180      but it is a ByteString parser; it will return the first valid utf8-encoded
 181      Char in a ByteString, whatever its byte-length,
 182      and the first byte following, if both exist. Because
 183      we \'draw\' one and \'peek\' at the other, the parser as a whole only
 184      advances one Char's length along the bytestring, whatever that length may be.
 185      See the slightly more complex example \'decode.hs\' in the
 186      <http://www.haskellforall.com/2014/02/pipes-parse-30-lens-based-parsing.html#batteries-included haskellforall blog>
 187      discussion of this type of byte stream parsing.
 188     -}
 189
 190 type Lens' a b = forall f . Functor f => (b -> f b) -> (a -> f a)
 191
 192 type Codec
 193     =  forall m r
 194     .  Monad m
 195     => Lens' (Producer ByteString m r)
 196              (Producer Text m (Producer ByteString m r))
 197
 198
 199 {- | @decode@ is just the ordinary @view@ or @(^.)@ of the lens libraries;
 200    exported here under a name appropriate to the material. Thus
 201
 202 >    decode utf8 bytes :: Producer Text IO (Producer ByteString IO ())
 203
 204     All of these are thus the same:
 205
 206 >    decode utf8 bytes = view utf8 bytes = bytes ^. utf8 = decodeUtf8 bytes
 207
 208
 209 -}
 210
 211 decode :: ((b -> Constant b b) -> (a -> Constant b a)) -> a -> b
 212 decode codec a = getConstant (codec Constant a)
 213
 214 {- | @eof@ tells you explicitly when decoding stops due to bad bytes or
 215     instead reaches end-of-file happily. (Without it one just makes an explicit
 216     test for emptiness of the resulting bytestring production using next) Thus
 217
 218 >    decode (utf8 . eof) bytes :: Producer T.Text IO (Either (Producer B.ByteString IO ()) ())
 219
 220     If we hit undecodable bytes, the remaining bytestring producer will be
 221     returned as a Left value; in the happy case, a Right value is returned
 222     with the anticipated return value for the original bytestring producer.
 223
 224     Again, all of these are the same
 225
 226 >    decode (utf8 . eof) bytes = view (utf8 . eof) p = p^.utf8.eof
 227
 228 -}
 229
 230 eof :: Monad m => Lens' (Producer Text m (Producer ByteString m r))
 231                        (Producer Text m (Either (Producer ByteString m r) r))
 232 eof k p0 = fmap fromEither (k (toEither p0)) where
 233
 234  fromEither = liftM (either id return)
 235
 236  toEither pp = do p <- pp
 237                   check p
 238
 239  check p = do e <- lift (next p)
 240               case e of
 241                 Left r -> return (Right r)
 242                 Right (bs,pb) ->  if B.null bs
 243                                     then check pb
 244                                     else return (Left (do yield bs
 245                                                           pb))
 246
 247 utf8 :: Codec
 248 utf8 = mkCodec decodeUtf8 TE.encodeUtf8
 249
 250 utf8Pure :: Codec
 251 utf8Pure = mkCodec decodeUtf8Pure TE.encodeUtf8
 252
 253 utf16LE :: Codec
 254 utf16LE = mkCodec decodeUtf16LE TE.encodeUtf16LE
 255
 256 utf16BE :: Codec
 257 utf16BE = mkCodec decodeUtf16BE TE.encodeUtf16BE
 258
 259 utf32LE :: Codec
 260 utf32LE = mkCodec decodeUtf32LE TE.encodeUtf32LE
 261
 262 utf32BE :: Codec
 263 utf32BE = mkCodec decodeUtf32BE TE.encodeUtf32BE
 264
 265 decodeStream :: Monad m
 266        => (B.ByteString -> DecodeResult)
 267        -> Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 268 decodeStream = loop where
 269   loop dec0 p =
 270     do x <- lift (next p)
 271        case x of
 272          Left r -> return (return r)
 273          Right (chunk, p') -> case dec0 chunk of
 274            DecodeResultSuccess text dec -> do yield text
 275                                               loop dec p'
 276            DecodeResultFailure text bs -> do yield text
 277                                              return (do yield bs
 278                                                         p')
 279 {-# INLINABLE decodeStream#-}
 280
 281
 282 {- $decoders
 283    These are functions with the simple type:
 284
 285 >   decodeUtf8 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 286
 287    Thus in general
 288
 289 >     decodeUtf8 = view utf8
 290 >     decodeUtf16LE = view utf16LE
 291
 292    and so forth, but these forms
 293    may be more convenient (and give better type errors!) where lenses are
 294    not desired.
 295 -}
 296
 297
 298 decodeUtf8 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 299 decodeUtf8 = decodeStream Stream.decodeUtf8
 300 {-# INLINE decodeUtf8 #-}
 301
 302 decodeUtf8Pure :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 303 decodeUtf8Pure = decodeStream Stream.decodeUtf8Pure
 304 {-# INLINE decodeUtf8Pure #-}
 305
 306 decodeUtf16LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 307 decodeUtf16LE = decodeStream Stream.decodeUtf16LE
 308 {-# INLINE decodeUtf16LE #-}
 309
 310 decodeUtf16BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 311 decodeUtf16BE = decodeStream Stream.decodeUtf16BE
 312 {-# INLINE decodeUtf16BE #-}
 313
 314 decodeUtf32LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 315 decodeUtf32LE = decodeStream Stream.decodeUtf32LE
 316 {-# INLINE decodeUtf32LE #-}
 317
 318 decodeUtf32BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 319 decodeUtf32BE = decodeStream Stream.decodeUtf32BE
 320 {-# INLINE decodeUtf32BE #-}
 321
 322
 323 {- $encoders
 324    These are simply defined
 325
 326 >      encodeUtf8 = yield . TE.encodeUtf8
 327
 328    They are intended for use with 'for'
 329
 330 >      for Text.stdin encodeUtf8 :: Producer ByteString IO ()
 331
 332    which would have the effect of
 333
 334 >      Text.stdin >-> Pipes.Prelude.map (TE.encodeUtf8)
 335
 336    using the encoding functions from Data.Text.Encoding
 337 -}
 338
 339 encodeUtf8 :: Monad m => Text -> Producer' ByteString m ()
 340 encodeUtf8 = yield . TE.encodeUtf8
 341 encodeUtf16LE :: Monad m => Text -> Producer' ByteString m ()
 342 encodeUtf16LE = yield . TE.encodeUtf16LE
 343 encodeUtf16BE :: Monad m => Text -> Producer' ByteString m ()
 344 encodeUtf16BE = yield . TE.encodeUtf16BE
 345 encodeUtf32LE :: Monad m => Text -> Producer' ByteString m ()
 346 encodeUtf32LE = yield . TE.encodeUtf32LE
 347 encodeUtf32BE :: Monad m => Text -> Producer' ByteString m ()
 348 encodeUtf32BE = yield . TE.encodeUtf32BE
 349
 350 mkCodec :: (forall r m . Monad m =>
 351            Producer ByteString m r -> Producer Text m (Producer ByteString m r ))
 352         -> (Text -> ByteString)
 353         -> Codec
 354 mkCodec dec enc = \k p0 -> fmap (\p -> join (for p (yield . enc)))  (k (dec p0))
 355
 356
 357
 358 {- $ascii
 359    ascii and latin encodings only use a small number of the characters 'Text'
 360      recognizes; thus we cannot use the pipes @Lens@ style to work with them.
 361      Rather we simply define functions each way.
 362 -}
 363
 364
 365 -- | 'encodeAscii' reduces as much of your stream of 'Text' actually is ascii to a byte stream,
 366 --   returning the rest of the 'Text' at the first non-ascii 'Char'
 367
 368 encodeAscii :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
 369 encodeAscii = go where
 370   go p = do e <- lift (next p)
 371             case e of
 372               Left r -> return (return r)
 373               Right (chunk, p') ->
 374                  if T.null chunk
 375                    then go p'
 376                    else let (safe, unsafe)  = T.span (\c -> ord c <= 0x7F) chunk
 377                         in do yield (B8.pack (T.unpack safe))
 378                               if T.null unsafe
 379                                 then go p'
 380                                 else return $ do yield unsafe
 381                                                  p'
 382
 383 {- | Reduce as much of your stream of 'Text' actually is iso8859 or latin1 to a byte stream,
 384      returning the rest of the 'Text' upon hitting any non-latin 'Char'
 385    -}
 386 encodeIso8859_1 :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
 387 encodeIso8859_1 = go where
 388   go p = do e <- lift (next p)
 389             case e of
 390               Left r -> return (return r)
 391               Right (txt, p') ->
 392                  if T.null txt
 393                    then go p'
 394                    else let (safe, unsafe)  = T.span (\c -> ord c <= 0xFF) txt
 395                         in do yield (B8.pack (T.unpack safe))
 396                               if T.null unsafe
 397                                 then go p'
 398                                 else return $ do yield unsafe
 399                                                  p'
 400
 401 {- | Reduce a byte stream to a corresponding stream of ascii chars, returning the
 402      unused 'ByteString' upon hitting an un-ascii byte.
 403    -}
 404 decodeAscii :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 405 decodeAscii = go where
 406   go p = do e <- lift (next p)
 407             case e of
 408               Left r -> return (return r)
 409               Right (chunk, p') ->
 410                  if B.null chunk
 411                    then go p'
 412                    else let (safe, unsafe) = B.span (<= 0x7F) chunk
 413                         in do yield (T.pack (B8.unpack safe))
 414                               if B.null unsafe
 415                                 then go p'
 416                                 else return (do yield unsafe
 417                                                 p')
 418
 419 {- | Reduce a byte stream to a corresponding stream of ascii chars, returning the
 420      unused 'ByteString' upon hitting the rare un-latinizable byte.
 421      -}
 422 decodeIso8859_1 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
 423 decodeIso8859_1 = go where
 424   go p = do e <- lift (next p)
 425             case e of
 426               Left r -> return (return r)
 427               Right (chunk, p') ->
 428                  if B.null chunk
 429                     then go p'
 430                     else do let (safe, unsafe) = B.span (<= 0xFF) chunk
 431                             yield (T.pack (B8.unpack safe))
 432                             if B.null unsafe
 433                                then go p'
 434                                else return (do yield unsafe
 435                                                p')
 436
 437
 438