{-# 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 forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word16 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word16 w) pushWord16le :: Word16 -> m () pushWord16le Word16 w = do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word16 w) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word16 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) pushWord32be :: Word32 -> m () pushWord32be Word32 w = do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 24) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 16) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w) pushWord32le :: Word32 -> m () pushWord32le Word32 w = do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 16) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word32 w forall a. Bits a => a -> Int -> a `shiftR` Int 24) pushWord64be :: Word64 -> m () pushWord64be Word64 w = do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 56) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 48) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 40) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 32) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 24) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 16) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w) pushWord64le :: Word64 -> m () pushWord64le Word64 w = do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 8) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 16) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 24) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 32) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 40) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 48) forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 (forall a b. (Integral a, Num b) => a -> b fromIntegral forall a b. (a -> b) -> a -> b $ Word64 w forall a. Bits a => a -> Int -> a `shiftR` Int 56) instance Throws EncodingException PutM where throwException :: forall a. EncodingException -> PutM a throwException = 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 = 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 = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (forall (f :: * -> *) a. Applicative f => a -> f a pure (),a x) <*> :: forall a 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 = 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 = forall a. Either EncodingException (PutM (), a) -> PutME a PutME 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 -> forall a b. a -> Either a b Left EncodingException err Right (PutM () m',b nr) -> forall a b. b -> Either a b Right (PutM () mforall (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 = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> Either a b Left instance ByteSink PutME where pushWord8 :: Word8 -> PutME () pushWord8 Word8 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word8 -> PutM () putWord8 Word8 w,()) pushWord16be :: Word16 -> PutME () pushWord16be Word16 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word16 -> PutM () putWord16be Word16 w,()) pushWord16le :: Word16 -> PutME () pushWord16le Word16 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word16 -> PutM () putWord16le Word16 w,()) pushWord32be :: Word32 -> PutME () pushWord32be Word32 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word32 -> PutM () putWord32be Word32 w,()) pushWord32le :: Word32 -> PutME () pushWord32le Word32 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word32 -> PutM () putWord32le Word32 w,()) pushWord64be :: Word64 -> PutME () pushWord64be Word64 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ forall a b. b -> Either a b Right (Word64 -> PutM () putWord64be Word64 w,()) pushWord64le :: Word64 -> PutME () pushWord64le Word64 w = forall a. Either EncodingException (PutM (), a) -> PutME a PutME forall a b. (a -> b) -> a -> b $ 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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify (forall a. Seq a -> a -> Seq a |> (Int -> Char chr forall a b. (a -> b) -> a -> b $ 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 = 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 = forall a. (Ptr Word8 -> Int -> Int -> IO (a, Ptr Word8, Int, Int)) -> StrictSink a StrictS forall a b. (a -> b) -> a -> b $ \Ptr Word8 cstr Int pos Int max -> 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 (<*>) = 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 = 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 = 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 = forall a e. Exception e => e -> a throw instance ByteSink StrictSink where pushWord8 :: Word8 -> StrictSink () pushWord8 Word8 x = 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 forall a. Ord a => a -> a -> Bool < Int max then forall (m :: * -> *) a. Monad m => a -> m a return (Ptr Word8 cstr,Int max) else (do let nmax :: Int nmax = Int max forall a. Num a => a -> a -> a + Int 32 Ptr Word8 nptr <- forall a. Ptr a -> Int -> IO (Ptr a) reallocBytes Ptr Word8 cstr Int nmax forall (m :: * -> *) a. Monad m => a -> m a return (Ptr Word8 nptr,Int nmax) ) forall a. Storable a => Ptr a -> a -> IO () poke (Ptr Word8 ncstr forall a b. Ptr a -> Int -> Ptr b `plusPtr` Int pos) Word8 x forall (m :: * -> *) a. Monad m => a -> m a return ((),Ptr Word8 ncstr,Int posforall 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM instance Applicative StrictSinkE where pure :: forall a. a -> StrictSinkE a pure = forall a. StrictSink (Either EncodingException a) -> StrictSinkE a StrictSinkE forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. b -> Either a b Right <*> :: forall a 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 = 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 = forall a. StrictSink (Either EncodingException a) -> StrictSinkE a StrictSinkE 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 -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> 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 = forall a. StrictSink (Either EncodingException a) -> StrictSinkE a StrictSinkE forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> Either a b Left instance ByteSink StrictSinkE where pushWord8 :: Word8 -> StrictSinkE () pushWord8 Word8 x = forall a. StrictSink (Either EncodingException a) -> StrictSinkE a StrictSinkE forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 Word8 x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 = forall a. IO a -> a unsafePerformIO forall a b. (a -> b) -> a -> b $ do Ptr Word8 ptr <- 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 (forall a. Ptr a -> IO () free Ptr Word8 nptr) 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 = 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r liftM instance Applicative StrictSinkExplicit where pure :: forall a. a -> StrictSinkExplicit a pure = (forall a. StrictSink (Either EncodingException a) -> StrictSinkExplicit a StrictSinkExplicit)forall b c a. (b -> c) -> (a -> b) -> a -> c .forall (m :: * -> *) a. Monad m => a -> m a returnforall b c a. (b -> c) -> (a -> b) -> a -> c .forall a b. b -> Either a b Right <*> :: forall a 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 = 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 = 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 -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> 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 = forall a. StrictSink (Either EncodingException a) -> StrictSinkExplicit a StrictSinkExplicit forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *) a. Monad m => a -> m a return forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. a -> Either a b Left instance ByteSink StrictSinkExplicit where pushWord8 :: Word8 -> StrictSinkExplicit () pushWord8 Word8 x = forall a. StrictSink (Either EncodingException a) -> StrictSinkExplicit a StrictSinkExplicit forall a b. (a -> b) -> a -> b $ do forall (m :: * -> *). ByteSink m => Word8 -> m () pushWord8 Word8 x forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ 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 <- forall r (m :: * -> *). MonadReader r m => m r ask forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO forall a b. (a -> b) -> a -> b $ do Handle -> Char -> IO () hPutChar Handle h (Int -> Char chr forall a b. (a -> b) -> a -> b $ forall a b. (Integral a, Num b) => a -> b fromIntegral Word8 x)