{-# 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.State
import Control.Monad.Identity
import Control.Monad.Reader
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
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word16 -> m Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> m Word16) -> Word16 -> m Word16
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2)
fetchWord16le :: m Word16
fetchWord16le = do
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word16 -> m Word16
forall (m :: * -> *) a. Monad m => a -> m a
return (Word16 -> m Word16) -> Word16 -> m Word16
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1)
fetchWord32be :: m Word32
fetchWord32be = do
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w3 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w4 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word32 -> m Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> m Word32) -> Word32 -> m Word32
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4)
fetchWord32le :: m Word32
fetchWord32le = do
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w3 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w4 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word32 -> m Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> m Word32) -> Word32 -> m Word32
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2) Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1)
fetchWord64be :: m Word64
fetchWord64be = do
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w3 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w4 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w5 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w6 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w7 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w8 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word64 -> m Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> m Word64) -> Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
56)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
48)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
40)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w5) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w6) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w7) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8)
fetchWord64le :: m Word64
fetchWord64le = do
Word8
w1 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w2 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w3 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w4 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w5 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w6 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w7 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word8
w8 <- m Word8
forall (m :: * -> *). ByteSource m => m Word8
fetchWord8
Word64 -> m Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> m Word64) -> Word64 -> m Word64
forall a b. (a -> b) -> a -> b
$ ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w8) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
56)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w7) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
48)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w6) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
40)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w5) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
32)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w4) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
24)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w3) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
16)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. ((Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w2) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
8)
Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w1)
instance Throws DecodingException Get where
throwException :: DecodingException -> Get a
throwException = DecodingException -> Get a
forall a e. 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 :: Get (Maybe a) -> Get (Maybe a)
fetchAhead Get (Maybe a)
act = (do
Maybe a
res <- Get (Maybe a)
act
case Maybe a
res of
Maybe a
Nothing -> Get (Maybe a)
forall (f :: * -> *) a. Alternative f => f a
A.empty
Just a
a -> Maybe a -> Get (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res
) Get (Maybe a) -> Get (Maybe a) -> Get (Maybe a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe a -> Get (Maybe 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
s
chs <- m s
forall s (m :: * -> *). MonadState s m => m s
get
Maybe a
res <- m (Maybe a)
act
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
res) (s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put s
chs)
Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
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 (t :: * -> *) a. Foldable t => t a -> Bool
null
fetchWord8 :: StateT [Char] Identity Word8
fetchWord8 = do
[Char]
chs <- StateT [Char] Identity [Char]
forall s (m :: * -> *). MonadState s m => m s
get
case [Char]
chs of
[] -> DecodingException -> StateT [Char] Identity Word8
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 (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 :: 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 (t :: * -> *) a. Foldable t => t a -> Bool
null
fetchWord8 :: StateT [Char] (Either DecodingException) Word8
fetchWord8 = do
[Char]
chs <- StateT [Char] (Either DecodingException) [Char]
forall s (m :: * -> *). MonadState s m => m s
get
case [Char]
chs of
[] -> DecodingException -> StateT [Char] (Either DecodingException) Word8
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 (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 :: 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 e (m :: * -> *) a. Throws e m => e -> m a
throwException DecodingException
UnexpectedEnd
Just (Word8
c,ByteString
cs) -> (Word8, ByteString) -> m (Word8, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
c,ByteString
cs))
fetchAhead :: 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 :: 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
Handle
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
IO Bool -> ReaderT Handle IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO Bool
hIsEOF Handle
h)
fetchWord8 :: ReaderT Handle IO Word8
fetchWord8 = do
Handle
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
IO Word8 -> ReaderT Handle IO Word8
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word8 -> ReaderT Handle IO Word8)
-> IO Word8 -> ReaderT Handle IO Word8
forall a b. (a -> b) -> a -> b
$ do
Char
ch <- Handle -> IO Char
hGetChar Handle
h
Word8 -> IO Word8
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
ch)
fetchAhead :: ReaderT Handle IO (Maybe a) -> ReaderT Handle IO (Maybe a)
fetchAhead ReaderT Handle IO (Maybe a)
act = do
Handle
h <- ReaderT Handle IO Handle
forall r (m :: * -> *). MonadReader r m => m r
ask
HandlePosn
pos <- IO HandlePosn -> ReaderT Handle IO HandlePosn
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO HandlePosn -> ReaderT Handle IO HandlePosn)
-> IO HandlePosn -> ReaderT Handle IO HandlePosn
forall a b. (a -> b) -> a -> b
$ Handle -> IO HandlePosn
hGetPosn Handle
h
Maybe a
res <- ReaderT Handle IO (Maybe a)
act
Bool -> ReaderT Handle IO () -> ReaderT Handle IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
res) (IO () -> ReaderT Handle IO ()
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
$ HandlePosn -> IO ()
hSetPosn HandlePosn
pos)
Maybe a -> ReaderT Handle IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
res