{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.PackStream.Internal.Binary where

import Data.PackStream.Internal.Type (PackStreamError(..))

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS (length)
import Data.ByteString.Lazy (fromStrict, toStrict)
import Data.Binary (Binary, encode, decode)
import Data.Binary.IEEE754 (wordToDouble, doubleToWord)
import Data.Text (Text)
import Data.Int (Int8, Int16, Int32, Int64)
import Control.Applicative (liftA2)
import Data.Word (Word8, Word16, Word32, Word64)
import Control.Monad.Except (throwError, MonadError)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)


-- |The data types that can be intepreted from 'ByteString'
class Interpret a where
    -- |Interpret a 'ByteString' as a specific type of raise 'PackStreamError'
    interpret :: MonadError PackStreamError m => ByteString -> m a

    default interpret :: (MonadError PackStreamError m, Binary a) => ByteString -> m a
    interpret = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> (ByteString -> a) -> ByteString -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
forall a. Binary a => ByteString -> a
decode (ByteString -> a) -> (ByteString -> ByteString) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict

instance Interpret Int8
instance Interpret Int16
instance Interpret Int32
instance Interpret Int64

instance Interpret Word8
instance Interpret Word16
instance Interpret Word32
instance Interpret Word64

instance Interpret Word where
    interpret :: ByteString -> m Word
interpret ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = forall b. (Integral Word8, Num b) => Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8  (Word8 -> Word) -> m Word8 -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Word8
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = forall b. (Integral Word16, Num b) => Word16 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 (Word16 -> Word) -> m Word16 -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Word16
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = forall b. (Integral Word32, Num b) => Word32 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 (Word32 -> Word) -> m Word32 -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Word32
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = forall b. (Integral Word64, Num b) => Word64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 (Word64 -> Word) -> m Word64 -> m Word
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Word64
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | Bool
otherwise         = PackStreamError -> m Word
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotWord

instance Interpret Int where
    interpret :: ByteString -> m Int
interpret ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = forall b. (Integral Int8, Num b) => Int8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int8  (Int8 -> Int) -> m Int8 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Int8
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 = forall b. (Integral Int16, Num b) => Int16 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int16 (Int16 -> Int) -> m Int16 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Int16
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4 = forall b. (Integral Int32, Num b) => Int32 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int32 (Int32 -> Int) -> m Int32 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Int32
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 = forall b. (Integral Int64, Num b) => Int64 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int64 (Int64 -> Int) -> m Int64 -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m Int64
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret ByteString
bs
                 | Bool
otherwise         = PackStreamError -> m Int
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError PackStreamError
NotInt

instance Interpret Integer where
    interpret :: ByteString -> m Integer
interpret = (Int -> Integer) -> m Int -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (m Int -> m Integer)
-> (ByteString -> m Int) -> ByteString -> m Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(Interpret Int, MonadError PackStreamError m) =>
ByteString -> m Int
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret @Int

instance Interpret Double where
    interpret :: ByteString -> m Double
interpret = (Word64 -> Double) -> m Word64 -> m Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Double
wordToDouble (m Word64 -> m Double)
-> (ByteString -> m Word64) -> ByteString -> m Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> m Word64
forall a (m :: * -> *).
(Interpret a, MonadError PackStreamError m) =>
ByteString -> m a
interpret

instance Interpret ByteString where
    interpret :: ByteString -> m ByteString
interpret = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance Interpret Text where
    interpret :: ByteString -> m Text
interpret = Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> (ByteString -> Text) -> ByteString -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8

-- |The data types that can be serialized into 'ByteString'
class Serialize a where
    -- |Serialize a specific data type into a 'ByteString'
    serialize :: a -> ByteString

    default serialize :: Binary a => a -> ByteString
    serialize = ByteString -> ByteString
toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode

instance Serialize Int8
instance Serialize Int16
instance Serialize Int32
instance Serialize Int64

instance Serialize Word8
instance Serialize Word16
instance Serialize Word32
instance Serialize Word64

instance Serialize Word where
    serialize :: Word -> ByteString
serialize Word
i | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0xFF               = Serialize Word8 => Word8 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Word8  (Word8 -> ByteString) -> Word8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i
                | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0xFFFF             = Serialize Word16 => Word16 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Word16 (Word16 -> ByteString) -> Word16 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i
                | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0xFFFFFFFF         = Serialize Word32 => Word32 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Word32 (Word32 -> ByteString) -> Word32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i
                | Word
i Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
0xFFFFFFFFFFFFFFFF = Serialize Word64 => Word64 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Word64 (Word64 -> ByteString) -> Word64 -> ByteString
forall a b. (a -> b) -> a -> b
$ Word -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i
                | Bool
otherwise               = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a 64-bit unsigned integer"

instance Serialize Int where
    serialize :: Int -> ByteString
serialize Int
i | Int -> Int -> Bool
forall a. Integral a => Int -> a -> Bool
inDepth  Int
8 Int
i = Serialize Int8 => Int8 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Int8  (Int8 -> ByteString) -> Int8 -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                | Int -> Int -> Bool
forall a. Integral a => Int -> a -> Bool
inDepth Int
16 Int
i = Serialize Int16 => Int16 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Int16 (Int16 -> ByteString) -> Int16 -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                | Int -> Int -> Bool
forall a. Integral a => Int -> a -> Bool
inDepth Int
32 Int
i = Serialize Int32 => Int32 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Int32 (Int32 -> ByteString) -> Int32 -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                | Int -> Int -> Bool
forall a. Integral a => Int -> a -> Bool
inDepth Int
64 Int
i = Serialize Int64 => Int64 -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Int64 (Int64 -> ByteString) -> Int64 -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                | Bool
otherwise    = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a 64-bit integer"

instance Serialize Integer where
    serialize :: Integer -> ByteString
serialize Integer
i | Int -> Integer -> Bool
forall a. Integral a => Int -> a -> Bool
inDepth Int
64 Integer
i = Serialize Int => Int -> ByteString
forall a. Serialize a => a -> ByteString
serialize @Int (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i
                | Bool
otherwise    = [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Not a 64-bit integer"

instance Serialize Double where
    serialize :: Double -> ByteString
serialize = Word64 -> ByteString
forall a. Serialize a => a -> ByteString
serialize (Word64 -> ByteString)
-> (Double -> Word64) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord

instance Serialize ByteString where
    serialize :: ByteString -> ByteString
serialize = ByteString -> ByteString
forall a. a -> a
id

instance Serialize Text where
    serialize :: Text -> ByteString
serialize = Text -> ByteString
encodeUtf8

-- |Check that the 'Integral' value is in the n-bit bounds
inDepth :: Integral a => Int -> a -> Bool
inDepth :: Int -> a -> Bool
inDepth Int
bitDepth = let bound :: Integer
bound = Integer
2 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
bitDepth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) :: Integer
                   in  (Bool -> Bool -> Bool)
-> (Integer -> Bool) -> (Integer -> Bool) -> Integer -> Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= -Integer
bound) (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
bound) (Integer -> Bool) -> (a -> Integer) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral