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