{-# 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 act' should return the same thing 'act' does, but should
    -- only consume input if 'act' returns a 'Just' value
    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