{-# LANGUAGE FlexibleInstances,FlexibleContexts,MultiParamTypeClasses,CPP #-}
module Data.Encoding.ByteSource where
import Data.Encoding.Exception
import Data.Bits
import Data.Binary.Get
import Data.Char
import Data.Maybe
import Data.Word
import Control.Applicative as A
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT (..), get, gets, put)
import Control.Monad.Identity (Identity)
import Control.Monad.Reader (ReaderT, ask)
import Control.Exception.Extensible
import Control.Throws
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import System.IO
class (Monad m,Throws DecodingException m) => ByteSource m where
sourceEmpty :: m Bool
fetchWord8 :: m Word8
fetchAhead :: m (Maybe a) -> m (Maybe a)
fetchWord16be :: m Word16
fetchWord16be = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 8)
.|. (fromIntegral w2)
fetchWord16le :: m Word16
fetchWord16le = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
return $ ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
fetchWord32be :: m Word32
fetchWord32be = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 24)
.|. ((fromIntegral w2) `shiftL` 16)
.|. ((fromIntegral w3) `shiftL` 8)
.|. (fromIntegral w4)
fetchWord32le :: m Word32
fetchWord32le = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
return $ ((fromIntegral w4) `shiftL` 24)
.|. ((fromIntegral w3) `shiftL` 16)
.|. ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
fetchWord64be :: m Word64
fetchWord64be = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
w5 <- fetchWord8
w6 <- fetchWord8
w7 <- fetchWord8
w8 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 56)
.|. ((fromIntegral w2) `shiftL` 48)
.|. ((fromIntegral w3) `shiftL` 40)
.|. ((fromIntegral w4) `shiftL` 32)
.|. ((fromIntegral w5) `shiftL` 24)
.|. ((fromIntegral w6) `shiftL` 16)
.|. ((fromIntegral w7) `shiftL` 8)
.|. (fromIntegral w8)
fetchWord64le :: m Word64
fetchWord64le = do
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
w5 <- fetchWord8
w6 <- fetchWord8
w7 <- fetchWord8
w8 <- fetchWord8
return $ ((fromIntegral w8) `shiftL` 56)
.|. ((fromIntegral w7) `shiftL` 48)
.|. ((fromIntegral w6) `shiftL` 40)
.|. ((fromIntegral w5) `shiftL` 32)
.|. ((fromIntegral w4) `shiftL` 24)
.|. ((fromIntegral w3) `shiftL` 16)
.|. ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
instance Throws DecodingException Get where
throwException :: forall a. DecodingException -> Get a
throwException = DecodingException -> Get a
forall a e. (HasCallStack, Exception e) => e -> a
throw
instance ByteSource Get where
sourceEmpty :: Get Bool
sourceEmpty = Get Bool
isEmpty
fetchWord8 :: Get Word8
fetchWord8 = Get Word8
getWord8
#if MIN_VERSION_binary(0,6,0)
fetchAhead :: forall a. Get (Maybe a) -> Get (Maybe a)
fetchAhead Get (Maybe a)
act = (do
res <- Get (Maybe a)
act
case res of
Maybe a
Nothing -> Get (Maybe a)
forall a. Get a
forall (f :: * -> *) a. Alternative f => f a
A.empty
Just a
a -> Maybe a -> Get (Maybe a)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res
) Get (Maybe a) -> Get (Maybe a) -> Get (Maybe a)
forall a. Get a -> Get a -> Get a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> Get (Maybe a)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
#else
fetchAhead act = do
res <- lookAhead act
case res of
Nothing -> return Nothing
Just a -> act
#endif
fetchWord16be :: Get Word16
fetchWord16be = Get Word16
getWord16be
fetchWord16le :: Get Word16
fetchWord16le = Get Word16
getWord16le
fetchWord32be :: Get Word32
fetchWord32be = Get Word32
getWord32be
fetchWord32le :: Get Word32
fetchWord32le = Get Word32
getWord32le
fetchWord64be :: Get Word64
fetchWord64be = Get Word64
getWord64be
fetchWord64le :: Get Word64
fetchWord64le = Get Word64
getWord64le
fetchAheadState :: m (Maybe a) -> m (Maybe a)
fetchAheadState m (Maybe a)
act = do
chs <- m s
forall s (m :: * -> *). MonadState s m => m s
get
res <- act
when (isNothing res) (put chs)
return res
instance ByteSource (StateT [Char] Identity) where
sourceEmpty :: StateT [Char] Identity Bool
sourceEmpty = ([Char] -> Bool) -> StateT [Char] Identity Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
fetchWord8 :: StateT [Char] Identity Word8
fetchWord8 = do
chs <- StateT [Char] Identity [Char]
forall s (m :: * -> *). MonadState s m => m s
get
case chs of
[] -> DecodingException -> StateT [Char] Identity Word8
forall a. DecodingException -> StateT [Char] Identity a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
UnexpectedEnd
Char
c:[Char]
cs -> do
[Char] -> StateT [Char] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Char]
cs
Word8 -> StateT [Char] Identity Word8
forall a. a -> StateT [Char] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c)
fetchAhead :: forall a.
StateT [Char] Identity (Maybe a)
-> StateT [Char] Identity (Maybe a)
fetchAhead = StateT [Char] Identity (Maybe a)
-> StateT [Char] Identity (Maybe a)
forall {m :: * -> *} {s} {a}.
MonadState s m =>
m (Maybe a) -> m (Maybe a)
fetchAheadState
#if MIN_VERSION_base(4,3,0)
#else
instance Monad (Either DecodingException) where
return = Right
(Left err) >>= g = Left err
(Right x) >>= g = g x
#endif
instance ByteSource (StateT [Char] (Either DecodingException)) where
sourceEmpty :: StateT [Char] (Either DecodingException) Bool
sourceEmpty = ([Char] -> Bool) -> StateT [Char] (Either DecodingException) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null
fetchWord8 :: StateT [Char] (Either DecodingException) Word8
fetchWord8 = do
chs <- StateT [Char] (Either DecodingException) [Char]
forall s (m :: * -> *). MonadState s m => m s
get
case chs of
[] -> DecodingException -> StateT [Char] (Either DecodingException) Word8
forall a.
DecodingException -> StateT [Char] (Either DecodingException) a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
UnexpectedEnd
Char
c:[Char]
cs -> do
[Char] -> StateT [Char] (Either DecodingException) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Char]
cs
Word8 -> StateT [Char] (Either DecodingException) Word8
forall a. a -> StateT [Char] (Either DecodingException) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c)
fetchAhead :: forall a.
StateT [Char] (Either DecodingException) (Maybe a)
-> StateT [Char] (Either DecodingException) (Maybe a)
fetchAhead = StateT [Char] (Either DecodingException) (Maybe a)
-> StateT [Char] (Either DecodingException) (Maybe a)
forall {m :: * -> *} {s} {a}.
MonadState s m =>
m (Maybe a) -> m (Maybe a)
fetchAheadState
instance (Monad m,Throws DecodingException m) => ByteSource (StateT BS.ByteString m) where
sourceEmpty :: StateT ByteString m Bool
sourceEmpty = (ByteString -> Bool) -> StateT ByteString m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ByteString -> Bool
BS.null
fetchWord8 :: StateT ByteString m Word8
fetchWord8 = (ByteString -> m (Word8, ByteString)) -> StateT ByteString m Word8
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\ByteString
str -> case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> DecodingException -> m (Word8, ByteString)
forall a. DecodingException -> m a
forall e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
UnexpectedEnd
Just (Word8
c,ByteString
cs) -> (Word8, ByteString) -> m (Word8, ByteString)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
c,ByteString
cs))
fetchAhead :: forall a.
StateT ByteString m (Maybe a) -> StateT ByteString m (Maybe a)
fetchAhead = StateT ByteString m (Maybe a) -> StateT ByteString m (Maybe a)
forall {m :: * -> *} {s} {a}.
MonadState s m =>
m (Maybe a) -> m (Maybe a)
fetchAheadState
instance ByteSource (StateT LBS.ByteString (Either DecodingException)) where
sourceEmpty :: StateT ByteString (Either DecodingException) Bool
sourceEmpty = (ByteString -> Bool)
-> StateT ByteString (Either DecodingException) Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ByteString -> Bool
LBS.null
fetchWord8 :: StateT ByteString (Either DecodingException) Word8
fetchWord8 = (ByteString -> Either DecodingException (Word8, ByteString))
-> StateT ByteString (Either DecodingException) Word8
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (\ByteString
str -> case ByteString -> Maybe (Word8, ByteString)
LBS.uncons ByteString
str of
Maybe (Word8, ByteString)
Nothing -> DecodingException -> Either DecodingException (Word8, ByteString)
forall a b. a -> Either a b
Left DecodingException
UnexpectedEnd
Just (Word8, ByteString)
ns -> (Word8, ByteString) -> Either DecodingException (Word8, ByteString)
forall a b. b -> Either a b
Right (Word8, ByteString)
ns)
fetchAhead :: forall a.
StateT ByteString (Either DecodingException) (Maybe a)
-> StateT ByteString (Either DecodingException) (Maybe a)
fetchAhead = StateT ByteString (Either DecodingException) (Maybe a)
-> StateT ByteString (Either DecodingException) (Maybe a)
forall {m :: * -> *} {s} {a}.
MonadState s m =>
m (Maybe a) -> m (Maybe a)
fetchAheadState
instance ByteSource (ReaderT Handle IO) where
sourceEmpty :: ReaderT Handle IO Bool
sourceEmpty = do
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
liftIO (hIsEOF h)
fetchWord8 :: ReaderT Handle IO Word8
fetchWord8 = do
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
liftIO $ do
ch <- hGetChar h
return (fromIntegral $ ord ch)
fetchAhead :: forall a.
ReaderT Handle IO (Maybe a) -> ReaderT Handle IO (Maybe a)
fetchAhead ReaderT Handle IO (Maybe a)
act = do
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
pos <- liftIO $ hGetPosn h
res <- act
when (isNothing res) (liftIO $ hSetPosn pos)
return res