{-# LANGUAGE FlexibleInstances,FlexibleContexts,MultiParamTypeClasses,CPP #-}
module Data.Encoding.ByteSink where

import Data.Encoding.Exception

import Data.Binary.Put
import Data.Bits
import Data.Char
import Data.Sequence
import Data.Word
import Data.Foldable (toList)
import Control.Throws
import Control.Exception.Extensible
import Control.Applicative
import Control.Monad (ap, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, modify)
import Control.Monad.Reader (ReaderT, ask)
import Foreign.Ptr (Ptr,plusPtr,minusPtr)
import Foreign.Marshal.Alloc (mallocBytes,reallocBytes,free)
import Foreign.Storable (poke)
import System.IO
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.ByteString as BS
import Data.ByteString.Unsafe (unsafePackCStringFinalizer)

class (Monad m,Throws EncodingException m) => ByteSink m where
    pushWord8 :: Word8 -> m ()
    pushWord16be :: Word16 -> m ()
    pushWord16be Word16
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Word16
w)
    pushWord16le :: Word16 -> m ()
    pushWord16le Word16
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Word16
w)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word8) -> Word16 -> Word8
forall a b. (a -> b) -> a -> b
$ Word16
w Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
    pushWord32be :: Word32 -> m ()
    pushWord32be Word32
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w)
    pushWord32le :: Word32 -> m ()
    pushWord32le Word32
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word8) -> Word32 -> Word8
forall a b. (a -> b) -> a -> b
$ Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
    pushWord64be :: Word64 -> m ()
    pushWord64be Word64
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
56)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
40)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w)
    pushWord64le :: Word64 -> m ()
    pushWord64le Word64
w = do
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR`  Int
8)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
24)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
40)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48)
      Word8 -> m ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
56)

instance Throws EncodingException PutM where
    throwException :: forall a. EncodingException -> PutM a
throwException = EncodingException -> PutM a
forall a e. Exception e => e -> a
throw

instance ByteSink PutM where
    pushWord8 :: Word8 -> PutM ()
pushWord8 = Word8 -> PutM ()
putWord8
    pushWord16be :: Word16 -> PutM ()
pushWord16be = Word16 -> PutM ()
putWord16be
    pushWord16le :: Word16 -> PutM ()
pushWord16le = Word16 -> PutM ()
putWord16le
    pushWord32be :: Word32 -> PutM ()
pushWord32be = Word32 -> PutM ()
putWord32be
    pushWord32le :: Word32 -> PutM ()
pushWord32le = Word32 -> PutM ()
putWord32le
    pushWord64be :: Word64 -> PutM ()
pushWord64be = Word64 -> PutM ()
putWord64be
    pushWord64le :: Word64 -> PutM ()
pushWord64le = Word64 -> PutM ()
putWord64le

newtype PutME a = PutME (Either EncodingException (PutM (),a))

instance Functor PutME where
  fmap :: forall a b. (a -> b) -> PutME a -> PutME b
fmap = (a -> b) -> PutME a -> PutME b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative PutME where
  pure :: forall a. a -> PutME a
pure a
x = Either EncodingException (PutM (), a) -> PutME a
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), a) -> PutME a)
-> Either EncodingException (PutM (), a) -> PutME a
forall a b. (a -> b) -> a -> b
$ (PutM (), a) -> Either EncodingException (PutM (), a)
forall a b. b -> Either a b
Right (() -> PutM ()
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (),a
x)
  <*> :: forall a b. PutME (a -> b) -> PutME a -> PutME b
(<*>) = PutME (a -> b) -> PutME a -> PutME b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad PutME where
    return :: forall a. a -> PutME a
return = a -> PutME a
forall a. a -> PutME a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (PutME Either EncodingException (PutM (), a)
x) >>= :: forall a b. PutME a -> (a -> PutME b) -> PutME b
>>= a -> PutME b
g = Either EncodingException (PutM (), b) -> PutME b
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), b) -> PutME b)
-> Either EncodingException (PutM (), b) -> PutME b
forall a b. (a -> b) -> a -> b
$ do
                        (PutM ()
m,a
r) <- Either EncodingException (PutM (), a)
x
                        let (PutME Either EncodingException (PutM (), b)
ng) = a -> PutME b
g a
r
                        case Either EncodingException (PutM (), b)
ng of
                          Left EncodingException
err -> EncodingException -> Either EncodingException (PutM (), b)
forall a b. a -> Either a b
Left EncodingException
err
                          Right (PutM ()
m',b
nr) -> (PutM (), b) -> Either EncodingException (PutM (), b)
forall a b. b -> Either a b
Right (PutM ()
mPutM () -> PutM () -> PutM ()
forall a b. PutM a -> PutM b -> PutM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>PutM ()
m',b
nr)

instance Throws EncodingException PutME where
    throwException :: forall a. EncodingException -> PutME a
throwException = Either EncodingException (PutM (), a) -> PutME a
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), a) -> PutME a)
-> (EncodingException -> Either EncodingException (PutM (), a))
-> EncodingException
-> PutME a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodingException -> Either EncodingException (PutM (), a)
forall a b. a -> Either a b
Left

instance ByteSink PutME where
    pushWord8 :: Word8 -> PutME ()
pushWord8 Word8
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word8 -> PutM ()
putWord8 Word8
w,())
    pushWord16be :: Word16 -> PutME ()
pushWord16be Word16
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word16 -> PutM ()
putWord16be Word16
w,())
    pushWord16le :: Word16 -> PutME ()
pushWord16le Word16
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word16 -> PutM ()
putWord16le Word16
w,())
    pushWord32be :: Word32 -> PutME ()
pushWord32be Word32
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word32 -> PutM ()
putWord32be Word32
w,())
    pushWord32le :: Word32 -> PutME ()
pushWord32le Word32
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word32 -> PutM ()
putWord32le Word32
w,())
    pushWord64be :: Word64 -> PutME ()
pushWord64be Word64
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word64 -> PutM ()
putWord64be Word64
w,())
    pushWord64le :: Word64 -> PutME ()
pushWord64le Word64
w = Either EncodingException (PutM (), ()) -> PutME ()
forall a. Either EncodingException (PutM (), a) -> PutME a
PutME (Either EncodingException (PutM (), ()) -> PutME ())
-> Either EncodingException (PutM (), ()) -> PutME ()
forall a b. (a -> b) -> a -> b
$ (PutM (), ()) -> Either EncodingException (PutM (), ())
forall a b. b -> Either a b
Right (Word64 -> PutM ()
putWord64le Word64
w,())

#if MIN_VERSION_base(4,3,0)
#else
instance Monad (Either EncodingException) where
    return x = Right x
    Left err >>= g = Left err
    Right x >>= g = g x
#endif

instance (Monad m,Throws EncodingException m) => ByteSink (StateT (Seq Char) m) where
    pushWord8 :: Word8 -> StateT (Seq Char) m ()
pushWord8 Word8
x = (Seq Char -> Seq Char) -> StateT (Seq Char) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Seq Char -> Char -> Seq Char
forall a. Seq a -> a -> Seq a
|> (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x))

newtype StrictSink a = StrictS (Ptr Word8 -> Int -> Int -> IO (a,Ptr Word8,Int,Int))

instance Functor StrictSink where
  fmap :: forall a b. (a -> b) -> StrictSink a -> StrictSink b
fmap = (a -> b) -> StrictSink a -> StrictSink b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative StrictSink where
  pure :: forall a. a -> StrictSink a
pure a
x = (Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
-> StrictSink a
forall a.
(Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
-> StrictSink a
StrictS ((Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
 -> StrictSink a)
-> (Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
-> StrictSink a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
cstr Int
pos Int
max -> (a, Ptr Word8, Int, Int) -> IO (a, Ptr Word8, Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x,Ptr Word8
cstr,Int
pos,Int
max)
  <*> :: forall a b. StrictSink (a -> b) -> StrictSink a -> StrictSink b
(<*>) = StrictSink (a -> b) -> StrictSink a -> StrictSink b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad StrictSink where
    return :: forall a. a -> StrictSink a
return = a -> StrictSink a
forall a. a -> StrictSink a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (StrictS Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int)
f) >>= :: forall a b. StrictSink a -> (a -> StrictSink b) -> StrictSink b
>>= a -> StrictSink b
g = (Ptr Word8 -> Int -> Int -> IO (b, Ptr Word8, Int, Int))
-> StrictSink b
forall a.
(Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
-> StrictSink a
StrictS (\Ptr Word8
cstr Int
pos Int
max -> do
                                   (a
res,Ptr Word8
ncstr,Int
npos,Int
nmax) <- Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int)
f Ptr Word8
cstr Int
pos Int
max
                                   let StrictS Ptr Word8 -> Int -> Int -> IO (b, Ptr Word8, Int, Int)
g' = a -> StrictSink b
g a
res
                                   Ptr Word8 -> Int -> Int -> IO (b, Ptr Word8, Int, Int)
g' Ptr Word8
ncstr Int
npos Int
nmax
                                )

instance Throws EncodingException StrictSink where
    throwException :: forall a. EncodingException -> StrictSink a
throwException = EncodingException -> StrictSink a
forall a e. Exception e => e -> a
throw

instance ByteSink StrictSink where
    pushWord8 :: Word8 -> StrictSink ()
pushWord8 Word8
x = (Ptr Word8 -> Int -> Int -> IO ((), Ptr Word8, Int, Int))
-> StrictSink ()
forall a.
(Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int))
-> StrictSink a
StrictS (\Ptr Word8
cstr Int
pos Int
max -> do
                             (Ptr Word8
ncstr,Int
nmax) <- if Int
pos Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max
                                    then (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8
cstr,Int
max)
                                    else (do
                                           let nmax :: Int
nmax = Int
max Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32
                                           Ptr Word8
nptr <- Ptr Word8 -> Int -> IO (Ptr Word8)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
cstr Int
nmax
                                           (Ptr Word8, Int) -> IO (Ptr Word8, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8
nptr,Int
nmax)
                                           )
                             Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
ncstr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
pos) Word8
x
                             ((), Ptr Word8, Int, Int) -> IO ((), Ptr Word8, Int, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((),Ptr Word8
ncstr,Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
nmax)
                          )

newtype StrictSinkE a = StrictSinkE (StrictSink (Either EncodingException a))

instance Functor StrictSinkE where
  fmap :: forall a b. (a -> b) -> StrictSinkE a -> StrictSinkE b
fmap = (a -> b) -> StrictSinkE a -> StrictSinkE b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative StrictSinkE where
  pure :: forall a. a -> StrictSinkE a
pure = StrictSink (Either EncodingException a) -> StrictSinkE a
forall a. StrictSink (Either EncodingException a) -> StrictSinkE a
StrictSinkE (StrictSink (Either EncodingException a) -> StrictSinkE a)
-> (a -> StrictSink (Either EncodingException a))
-> a
-> StrictSinkE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either EncodingException a
-> StrictSink (Either EncodingException a)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException a
 -> StrictSink (Either EncodingException a))
-> (a -> Either EncodingException a)
-> a
-> StrictSink (Either EncodingException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either EncodingException a
forall a b. b -> Either a b
Right
  <*> :: forall a b. StrictSinkE (a -> b) -> StrictSinkE a -> StrictSinkE b
(<*>) = StrictSinkE (a -> b) -> StrictSinkE a -> StrictSinkE b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad StrictSinkE where
    return :: forall a. a -> StrictSinkE a
return = a -> StrictSinkE a
forall a. a -> StrictSinkE a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (StrictSinkE StrictSink (Either EncodingException a)
s) >>= :: forall a b. StrictSinkE a -> (a -> StrictSinkE b) -> StrictSinkE b
>>= a -> StrictSinkE b
g = StrictSink (Either EncodingException b) -> StrictSinkE b
forall a. StrictSink (Either EncodingException a) -> StrictSinkE a
StrictSinkE (StrictSink (Either EncodingException b) -> StrictSinkE b)
-> StrictSink (Either EncodingException b) -> StrictSinkE b
forall a b. (a -> b) -> a -> b
$ do
                              Either EncodingException a
res <- StrictSink (Either EncodingException a)
s
                              case Either EncodingException a
res of
                                Left EncodingException
err -> Either EncodingException b
-> StrictSink (Either EncodingException b)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException b
 -> StrictSink (Either EncodingException b))
-> Either EncodingException b
-> StrictSink (Either EncodingException b)
forall a b. (a -> b) -> a -> b
$ EncodingException -> Either EncodingException b
forall a b. a -> Either a b
Left EncodingException
err
                                Right a
res' -> let StrictSinkE StrictSink (Either EncodingException b)
g' = a -> StrictSinkE b
g a
res'
                                             in StrictSink (Either EncodingException b)
g'

instance Throws EncodingException StrictSinkE where
    throwException :: forall a. EncodingException -> StrictSinkE a
throwException = StrictSink (Either EncodingException a) -> StrictSinkE a
forall a. StrictSink (Either EncodingException a) -> StrictSinkE a
StrictSinkE (StrictSink (Either EncodingException a) -> StrictSinkE a)
-> (EncodingException -> StrictSink (Either EncodingException a))
-> EncodingException
-> StrictSinkE a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either EncodingException a
-> StrictSink (Either EncodingException a)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException a
 -> StrictSink (Either EncodingException a))
-> (EncodingException -> Either EncodingException a)
-> EncodingException
-> StrictSink (Either EncodingException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodingException -> Either EncodingException a
forall a b. a -> Either a b
Left

instance ByteSink StrictSinkE where
    pushWord8 :: Word8 -> StrictSinkE ()
pushWord8 Word8
x = StrictSink (Either EncodingException ()) -> StrictSinkE ()
forall a. StrictSink (Either EncodingException a) -> StrictSinkE a
StrictSinkE (StrictSink (Either EncodingException ()) -> StrictSinkE ())
-> StrictSink (Either EncodingException ()) -> StrictSinkE ()
forall a b. (a -> b) -> a -> b
$ Word8 -> StrictSink ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 Word8
x StrictSink ()
-> (() -> StrictSink (Either EncodingException ()))
-> StrictSink (Either EncodingException ())
forall a b. StrictSink a -> (a -> StrictSink b) -> StrictSink b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either EncodingException ()
-> StrictSink (Either EncodingException ())
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException ()
 -> StrictSink (Either EncodingException ()))
-> (() -> Either EncodingException ())
-> ()
-> StrictSink (Either EncodingException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. () -> Either EncodingException ()
forall a b. b -> Either a b
Right

createStrictWithLen :: StrictSink a -> Int -> (a,BS.ByteString)
createStrictWithLen :: forall a. StrictSink a -> Int -> (a, ByteString)
createStrictWithLen (StrictS Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int)
f) Int
max = IO (a, ByteString) -> (a, ByteString)
forall a. IO a -> a
unsafePerformIO (IO (a, ByteString) -> (a, ByteString))
-> IO (a, ByteString) -> (a, ByteString)
forall a b. (a -> b) -> a -> b
$ do
                                 Ptr Word8
ptr <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
max
                                 (a
r,Ptr Word8
nptr,Int
len,Int
_) <- Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int)
f Ptr Word8
ptr Int
0 Int
max
                                 ByteString
str <- Ptr Word8 -> Int -> IO () -> IO ByteString
unsafePackCStringFinalizer Ptr Word8
nptr Int
len (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
nptr)
                                 (a, ByteString) -> IO (a, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r,ByteString
str)

createStrict :: StrictSink a -> (a,BS.ByteString)
createStrict :: forall a. StrictSink a -> (a, ByteString)
createStrict StrictSink a
sink = StrictSink a -> Int -> (a, ByteString)
forall a. StrictSink a -> Int -> (a, ByteString)
createStrictWithLen StrictSink a
sink Int
32

newtype StrictSinkExplicit a = StrictSinkExplicit  (StrictSink (Either EncodingException a))

instance Functor StrictSinkExplicit where
  fmap :: forall a b.
(a -> b) -> StrictSinkExplicit a -> StrictSinkExplicit b
fmap = (a -> b) -> StrictSinkExplicit a -> StrictSinkExplicit b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative StrictSinkExplicit where
  pure :: forall a. a -> StrictSinkExplicit a
pure = (StrictSink (Either EncodingException a) -> StrictSinkExplicit a
forall a.
StrictSink (Either EncodingException a) -> StrictSinkExplicit a
StrictSinkExplicit)(StrictSink (Either EncodingException a) -> StrictSinkExplicit a)
-> (a -> StrictSink (Either EncodingException a))
-> a
-> StrictSinkExplicit a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Either EncodingException a
-> StrictSink (Either EncodingException a)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return(Either EncodingException a
 -> StrictSink (Either EncodingException a))
-> (a -> Either EncodingException a)
-> a
-> StrictSink (Either EncodingException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.a -> Either EncodingException a
forall a b. b -> Either a b
Right
  <*> :: forall a b.
StrictSinkExplicit (a -> b)
-> StrictSinkExplicit a -> StrictSinkExplicit b
(<*>) = StrictSinkExplicit (a -> b)
-> StrictSinkExplicit a -> StrictSinkExplicit b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad StrictSinkExplicit where
    return :: forall a. a -> StrictSinkExplicit a
return = a -> StrictSinkExplicit a
forall a. a -> StrictSinkExplicit a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (StrictSinkExplicit StrictSink (Either EncodingException a)
sink) >>= :: forall a b.
StrictSinkExplicit a
-> (a -> StrictSinkExplicit b) -> StrictSinkExplicit b
>>= a -> StrictSinkExplicit b
f
        = StrictSink (Either EncodingException b) -> StrictSinkExplicit b
forall a.
StrictSink (Either EncodingException a) -> StrictSinkExplicit a
StrictSinkExplicit (do
                               Either EncodingException a
res <- StrictSink (Either EncodingException a)
sink
                               case Either EncodingException a
res of
                                 Left EncodingException
err -> Either EncodingException b
-> StrictSink (Either EncodingException b)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException b
 -> StrictSink (Either EncodingException b))
-> Either EncodingException b
-> StrictSink (Either EncodingException b)
forall a b. (a -> b) -> a -> b
$ EncodingException -> Either EncodingException b
forall a b. a -> Either a b
Left EncodingException
err
                                 Right a
x -> let StrictSinkExplicit StrictSink (Either EncodingException b)
sink2 = a -> StrictSinkExplicit b
f a
x
                                           in StrictSink (Either EncodingException b)
sink2)

instance Throws EncodingException StrictSinkExplicit where
    throwException :: forall a. EncodingException -> StrictSinkExplicit a
throwException = StrictSink (Either EncodingException a) -> StrictSinkExplicit a
forall a.
StrictSink (Either EncodingException a) -> StrictSinkExplicit a
StrictSinkExplicit (StrictSink (Either EncodingException a) -> StrictSinkExplicit a)
-> (EncodingException -> StrictSink (Either EncodingException a))
-> EncodingException
-> StrictSinkExplicit a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either EncodingException a
-> StrictSink (Either EncodingException a)
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException a
 -> StrictSink (Either EncodingException a))
-> (EncodingException -> Either EncodingException a)
-> EncodingException
-> StrictSink (Either EncodingException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodingException -> Either EncodingException a
forall a b. a -> Either a b
Left

instance ByteSink StrictSinkExplicit where
    pushWord8 :: Word8 -> StrictSinkExplicit ()
pushWord8 Word8
x = StrictSink (Either EncodingException ()) -> StrictSinkExplicit ()
forall a.
StrictSink (Either EncodingException a) -> StrictSinkExplicit a
StrictSinkExplicit (StrictSink (Either EncodingException ()) -> StrictSinkExplicit ())
-> StrictSink (Either EncodingException ())
-> StrictSinkExplicit ()
forall a b. (a -> b) -> a -> b
$ do
                                       Word8 -> StrictSink ()
forall (m :: * -> *). ByteSink m => Word8 -> m ()
pushWord8 Word8
x
                                       Either EncodingException ()
-> StrictSink (Either EncodingException ())
forall a. a -> StrictSink a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either EncodingException ()
 -> StrictSink (Either EncodingException ()))
-> Either EncodingException ()
-> StrictSink (Either EncodingException ())
forall a b. (a -> b) -> a -> b
$ () -> Either EncodingException ()
forall a b. b -> Either a b
Right ()

instance ByteSink (ReaderT Handle IO) where
    pushWord8 :: Word8 -> ReaderT Handle IO ()
pushWord8 Word8
x = do
      Handle
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
      IO () -> ReaderT Handle IO ()
forall a. IO a -> ReaderT Handle IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Handle IO ()) -> IO () -> ReaderT Handle IO ()
forall a b. (a -> b) -> a -> b
$ do
        Handle -> Char -> IO ()
hPutChar Handle
h (Int -> Char
chr (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)