[github/fretlink/text-pipes.git] / Pipes / Text / Encoding.hs


{-# LANGUAGE RankNTypes, BangPatterns #-}
-- |
-- Copyright: 2014 Michael Thompson
--
-- This module uses the stream decoding functions from the text-stream-decoding package
-- to define pipes decoding functions and lenses.

module Pipes.Text.Encoding
    ( DecodeResult (..)
    , Codec
    , decodeUtf8
    , decodeUtf8Pure
    , decodeUtf16LE
    , decodeUtf16BE
    , decodeUtf32LE
    , decodeUtf32BE
    , utf8
    , utf8Pure
    , utf16LE
    , utf16BE
    , utf32LE
    , utf32BE
    , encodeAscii
    , decodeAscii
    , encodeIso8859_1
    , decodeIso8859_1
    ) 
    where

import Data.Char (ord)
import Data.ByteString as B 
import Data.ByteString (ByteString)
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.StreamDecoding
import Control.Monad (join)
import Pipes


{- | A 'Codec' is just an improper lens into a byte stream that is expected to contain text.
    They are named in accordance with the expected encoding, 'utf8', 'utf16LE' etc.
    The stream of text they 'see' in a bytestream ends by returning the original byte stream 
    beginning at the point of failure, or the empty bytestream with its return value.
   -}
type Codec  = forall f m r . (Functor f , Monad m ) => 
     (Producer Text m (Producer ByteString m r) -> f (Producer Text m (Producer ByteString m r)))
     -> Producer ByteString m r -> f (Producer ByteString m r )

decodeStream :: Monad m 
       => (B.ByteString -> DecodeResult) 
       -> Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeStream = loop where
  loop dec0 p = 
    do x <- lift (next p) 
       case x of Left r -> return (return r)
                 Right (chunk, p') -> case dec0 chunk of 
                    DecodeResultSuccess text dec -> do yield text
                                                       loop dec p'
                    DecodeResultFailure text bs -> do yield text 
                                                      return (do yield bs 
                                                                 p')
{-# INLINABLE decodeStream#-}

decodeUtf8 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf8 = decodeStream streamUtf8
{-# INLINE decodeUtf8 #-}

decodeUtf8Pure :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf8Pure = decodeStream streamUtf8Pure
{-# INLINE decodeUtf8Pure #-}

decodeUtf16LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf16LE = decodeStream streamUtf16LE
{-# INLINE decodeUtf16LE #-}

decodeUtf16BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf16BE = decodeStream streamUtf16BE
{-# INLINE decodeUtf16BE #-}

decodeUtf32LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf32LE = decodeStream streamUtf32LE
{-# INLINE decodeUtf32LE #-}

decodeUtf32BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeUtf32BE = decodeStream streamUtf32BE
{-# INLINE decodeUtf32BE #-}

mkCodec :: (forall r m . Monad m => 
           Producer ByteString m r -> Producer Text m (Producer ByteString m r ))
        -> (Text -> ByteString)
        -> Codec
mkCodec dec enc = \k p0 -> fmap (\p -> join (for p (yield . enc)))  (k (dec p0))


{- | An improper lens into a byte stream expected to be UTF-8 encoded; the associated
   text stream ends by returning the original bytestream beginning at the point of failure,
   or the empty bytestring for a well-encoded text. 
   -}

utf8 :: Codec
utf8 = mkCodec decodeUtf8 TE.encodeUtf8

utf8Pure :: Codec
utf8Pure = mkCodec decodeUtf8Pure TE.encodeUtf8

utf16LE :: Codec
utf16LE = mkCodec decodeUtf16LE TE.encodeUtf16LE

utf16BE :: Codec
utf16BE = mkCodec decodeUtf16BE TE.encodeUtf16BE

utf32LE :: Codec
utf32LE = mkCodec decodeUtf32LE TE.encodeUtf32LE

utf32BE :: Codec
utf32BE = mkCodec decodeUtf32BE TE.encodeUtf32BE


{- | ascii and latin encodings only use a small number of the characters 'Text'
     recognizes; thus we cannot use the pipes 'Lens' style to work with them. 
     Rather we simply define functions each way. 

     'encodeAscii' : Reduce as much of your stream of 'Text' actually is ascii to a byte stream,
     returning the rest of the 'Text' at the first non-ascii 'Char'
-}

encodeAscii :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
encodeAscii = go where
  go p = do e <- lift (next p)
            case e 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'
                                                 
{- | Reduce as much of your stream of 'Text' actually is iso8859 or latin1 to a byte stream,
     returning the rest of the 'Text' upon hitting any non-latin 'Char'
   -}
encodeIso8859_1 :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
encodeIso8859_1 = go where
  go p = do e <- lift (next p)
            case e 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'

{- | Reduce a byte stream to a corresponding stream of ascii chars, returning the
     unused 'ByteString' upon hitting an un-ascii byte.
   -}
decodeAscii :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeAscii = go where
  go p = do e <- lift (next p)
            case e 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')

{- | Reduce a byte stream to a corresponding stream of ascii chars, returning the
     unused 'ByteString' upon hitting the rare un-latinizable byte.
     -}
decodeIso8859_1 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
decodeIso8859_1 = go where
  go p = do e <- lift (next p)
            case e of 
              Left r -> return (return r)
              Right (chunk, p') -> 
                 if B.null chunk 
                    then go p'
                    else do let (safe, unsafe) = B.span (<= 0xFF) chunk
                            yield (T.pack (B8.unpack safe))
                            if B.null unsafe 
                               then go p'
                               else return (do yield unsafe 
                                               p')
Commit	Line	Data
bbdfd305	1
	2	{-# LANGUAGE RankNTypes, BangPatterns #-}
	3	-- \|
	4	-- Copyright: 2014 Michael Thompson
	5	--
	6	-- This module uses the stream decoding functions from the text-stream-decoding package
	7	-- to define pipes decoding functions and lenses.
	8
	9	module Pipes.Text.Encoding
	10	( DecodeResult (..)
	11	, Codec
	12	, decodeUtf8
	13	, decodeUtf8Pure
	14	, decodeUtf16LE
	15	, decodeUtf16BE
	16	, decodeUtf32LE
	17	, decodeUtf32BE
	18	, utf8
	19	, utf8Pure
	20	, utf16LE
	21	, utf16BE
	22	, utf32LE
	23	, utf32BE
	24	, encodeAscii
	25	, decodeAscii
	26	, encodeIso8859_1
	27	, decodeIso8859_1
	28	)
	29	where
	30
	31	import Data.Char (ord)
	32	import Data.ByteString as B
	33	import Data.ByteString (ByteString)
bbdfd305	34	import Data.ByteString.Char8 as B8
	35	import Data.Text (Text)
	36	import qualified Data.Text as T
	37	import qualified Data.Text.Encoding as TE
	38	import Data.Text.StreamDecoding
70125641	39	import Control.Monad (join)
bbdfd305	40	import Pipes
bbdfd305	41
	42
	43
	44	{- \| A 'Codec' is just an improper lens into a byte stream that is expected to contain text.
	45	They are named in accordance with the expected encoding, 'utf8', 'utf16LE' etc.
	46	The stream of text they 'see' in a bytestream ends by returning the original byte stream
	47	beginning at the point of failure, or the empty bytestream with its return value.
	48	-}
	49	type Codec = forall f m r . (Functor f , Monad m ) =>
	50	(Producer Text m (Producer ByteString m r) -> f (Producer Text m (Producer ByteString m r)))
	51	-> Producer ByteString m r -> f (Producer ByteString m r )
	52
	53	decodeStream :: Monad m
	54	=> (B.ByteString -> DecodeResult)
	55	-> Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	56	decodeStream = loop where
	57	loop dec0 p =
	58	do x <- lift (next p)
	59	case x of Left r -> return (return r)
	60	Right (chunk, p') -> case dec0 chunk of
	61	DecodeResultSuccess text dec -> do yield text
	62	loop dec p'
	63	DecodeResultFailure text bs -> do yield text
	64	return (do yield bs
	65	p')
	66	{-# INLINABLE decodeStream#-}
	67
	68	decodeUtf8 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	69	decodeUtf8 = decodeStream streamUtf8
	70	{-# INLINE decodeUtf8 #-}
	71
	72	decodeUtf8Pure :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	73	decodeUtf8Pure = decodeStream streamUtf8Pure
	74	{-# INLINE decodeUtf8Pure #-}
	75
	76	decodeUtf16LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	77	decodeUtf16LE = decodeStream streamUtf16LE
	78	{-# INLINE decodeUtf16LE #-}
	79
	80	decodeUtf16BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	81	decodeUtf16BE = decodeStream streamUtf16BE
	82	{-# INLINE decodeUtf16BE #-}
	83
	84	decodeUtf32LE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	85	decodeUtf32LE = decodeStream streamUtf32LE
	86	{-# INLINE decodeUtf32LE #-}
	87
	88	decodeUtf32BE :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
	89	decodeUtf32BE = decodeStream streamUtf32BE
	90	{-# INLINE decodeUtf32BE #-}
	91
	92	mkCodec :: (forall r m . Monad m =>
	93	Producer ByteString m r -> Producer Text m (Producer ByteString m r ))
	94	-> (Text -> ByteString)
	95	-> Codec
	96	mkCodec dec enc = \k p0 -> fmap (\p -> join (for p (yield . enc))) (k (dec p0))
	97
	98
	99	{- \| An improper lens into a byte stream expected to be UTF-8 encoded; the associated
	100	text stream ends by returning the original bytestream beginning at the point of failure,
	101	or the empty bytestring for a well-encoded text.
	102	-}
	103
	104	utf8 :: Codec
105	utf8 = mkCodec decodeUtf8 TE.encodeUtf8
106
107	utf8Pure :: Codec
108	utf8Pure = mkCodec decodeUtf8Pure TE.encodeUtf8
109
110	utf16LE :: Codec
111	utf16LE = mkCodec decodeUtf16LE TE.encodeUtf16LE
112
113	utf16BE :: Codec
114	utf16BE = mkCodec decodeUtf16BE TE.encodeUtf16BE
115
116	utf32LE :: Codec
117	utf32LE = mkCodec decodeUtf32LE TE.encodeUtf32LE
118
119	utf32BE :: Codec
120	utf32BE = mkCodec decodeUtf32BE TE.encodeUtf32BE
121
122
123	{- \| ascii and latin encodings only use a small number of the characters 'Text'
124	recognizes; thus we cannot use the pipes 'Lens' style to work with them.
125	Rather we simply define functions each way.
126
127	'encodeAscii' : Reduce as much of your stream of 'Text' actually is ascii to a byte stream,
128	returning the rest of the 'Text' at the first non-ascii 'Char'
129	-}
130
131	encodeAscii :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
132	encodeAscii = go where
133	go p = do e <- lift (next p)
134	case e of
135	Left r -> return (return r)
136	Right (chunk, p') ->
137	if T.null chunk
138	then go p'
139	else let (safe, unsafe) = T.span (\c -> ord c <= 0x7F) chunk
140	in do yield (B8.pack (T.unpack safe))
141	if T.null unsafe
142	then go p'
143	else return $ do yield unsafe
144	p'
145
146	{- \| Reduce as much of your stream of 'Text' actually is iso8859 or latin1 to a byte stream,
147	returning the rest of the 'Text' upon hitting any non-latin 'Char'
148	-}
149	encodeIso8859_1 :: Monad m => Producer Text m r -> Producer ByteString m (Producer Text m r)
150	encodeIso8859_1 = go where
151	go p = do e <- lift (next p)
152	case e of
153	Left r -> return (return r)
154	Right (txt, p') ->
155	if T.null txt
156	then go p'
157	else let (safe, unsafe) = T.span (\c -> ord c <= 0xFF) txt
158	in do yield (B8.pack (T.unpack safe))
159	if T.null unsafe
160	then go p'
161	else return $ do yield unsafe
162	p'
163
164	{- \| Reduce a byte stream to a corresponding stream of ascii chars, returning the
165	unused 'ByteString' upon hitting an un-ascii byte.
166	-}
167	decodeAscii :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
168	decodeAscii = go where
169	go p = do e <- lift (next p)
170	case e of
171	Left r -> return (return r)
172	Right (chunk, p') ->
173	if B.null chunk
174	then go p'
175	else let (safe, unsafe) = B.span (<= 0x7F) chunk
176	in do yield (T.pack (B8.unpack safe))
177	if B.null unsafe
178	then go p'
179	else return (do yield unsafe
180	p')
181
182	{- \| Reduce a byte stream to a corresponding stream of ascii chars, returning the
183	unused 'ByteString' upon hitting the rare un-latinizable byte.
184	-}
185	decodeIso8859_1 :: Monad m => Producer ByteString m r -> Producer Text m (Producer ByteString m r)
186	decodeIso8859_1 = go where
187	go p = do e <- lift (next p)
188	case e of
189	Left r -> return (return r)
190	Right (chunk, p') ->
191	if B.null chunk
192	then go p'
193	else do let (safe, unsafe) = B.span (<= 0xFF) chunk
194	yield (T.pack (B8.unpack safe))
195	if B.null unsafe
196	then go p'
197	else return (do yield unsafe
198	p')
199
200
201