module Data.PrimitiveSerial
    ( BSRead(..)
    , runWholeBSRead
    , bsRead
    , bsReadN
    , bsReadEverything
    , bsReadCount
    , decodeNative
    , encodeNative
    , FixedNumeric(..)
    , decodeLittleEndian
    , encodeLittleEndian
    , decodeBigEndian
    , encodeBigEndian
    ) where

import Control.Applicative
import Control.Monad
import Data.ByteString
import Data.ByteString.Internal
import Data.Int
import Data.Word
import Foreign
import Prelude hiding (drop, length, null, take)
import System.Endian
import System.IO.Unsafe

newtype BSRead a = MkBSRead
    { forall a.
BSRead a -> StrictByteString -> Maybe (StrictByteString, a)
runBSRead :: StrictByteString -> Maybe (StrictByteString, a)
    }

instance Functor BSRead where
    fmap :: forall a b. (a -> b) -> BSRead a -> BSRead b
fmap a -> b
ab (MkBSRead StrictByteString -> Maybe (StrictByteString, a)
f) = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
ab) forall a b. (a -> b) -> a -> b
$ StrictByteString -> Maybe (StrictByteString, a)
f StrictByteString
bs

instance Applicative BSRead where
    pure :: forall a. a -> BSRead a
pure a
a = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> forall a. a -> Maybe a
Just (StrictByteString
bs, a
a)
    MkBSRead StrictByteString -> Maybe (StrictByteString, a -> b)
fab <*> :: forall a b. BSRead (a -> b) -> BSRead a -> BSRead b
<*> MkBSRead StrictByteString -> Maybe (StrictByteString, a)
fa =
        forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> do
            (StrictByteString
bs', a -> b
ab) <- StrictByteString -> Maybe (StrictByteString, a -> b)
fab StrictByteString
bs
            (StrictByteString
bs'', a
a) <- StrictByteString -> Maybe (StrictByteString, a)
fa StrictByteString
bs'
            forall (m :: * -> *) a. Monad m => a -> m a
return (StrictByteString
bs'', a -> b
ab a
a)

instance Alternative BSRead where
    MkBSRead StrictByteString -> Maybe (StrictByteString, a)
fa <|> :: forall a. BSRead a -> BSRead a -> BSRead a
<|> MkBSRead StrictByteString -> Maybe (StrictByteString, a)
fb = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> StrictByteString -> Maybe (StrictByteString, a)
fa StrictByteString
bs forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> StrictByteString -> Maybe (StrictByteString, a)
fb StrictByteString
bs
    empty :: forall a. BSRead a
empty = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
_ -> forall a. Maybe a
Nothing

instance Monad BSRead where
    MkBSRead StrictByteString -> Maybe (StrictByteString, a)
f >>= :: forall a b. BSRead a -> (a -> BSRead b) -> BSRead b
>>= a -> BSRead b
q =
        forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> do
            (StrictByteString
bs', a
a) <- StrictByteString -> Maybe (StrictByteString, a)
f StrictByteString
bs
            forall a.
BSRead a -> StrictByteString -> Maybe (StrictByteString, a)
runBSRead (a -> BSRead b
q a
a) StrictByteString
bs'

instance MonadPlus BSRead

runWholeBSRead :: BSRead a -> StrictByteString -> Maybe a
runWholeBSRead :: forall a. BSRead a -> StrictByteString -> Maybe a
runWholeBSRead BSRead a
ra StrictByteString
bs = do
    (StrictByteString
bs', a
a) <- forall a.
BSRead a -> StrictByteString -> Maybe (StrictByteString, a)
runBSRead BSRead a
ra StrictByteString
bs
    if StrictByteString -> Bool
null StrictByteString
bs'
        then forall (m :: * -> *) a. Monad m => a -> m a
return a
a
        else forall a. Maybe a
Nothing

bsRead :: BSRead Word8
bsRead :: BSRead Word8
bsRead =
    forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> do
        Word8
w <- StrictByteString -> Int -> Maybe Word8
indexMaybe StrictByteString
bs Int
0
        forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> StrictByteString -> StrictByteString
drop Int
1 StrictByteString
bs, Word8
w)

bsReadN :: Int -> BSRead StrictByteString
bsReadN :: Int -> BSRead StrictByteString
bsReadN Int
n =
    forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> do
        if Int
n forall a. Ord a => a -> a -> Bool
> StrictByteString -> Int
length StrictByteString
bs
            then forall a. Maybe a
Nothing
            else forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> StrictByteString -> StrictByteString
drop Int
n StrictByteString
bs, Int -> StrictByteString -> StrictByteString
take Int
n StrictByteString
bs)

bsReadEverything :: BSRead StrictByteString
bsReadEverything :: BSRead StrictByteString
bsReadEverything = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> forall a. a -> Maybe a
Just (forall a. Monoid a => a
mempty, StrictByteString
bs)

bsReadCount :: BSRead Int
bsReadCount :: BSRead Int
bsReadCount = forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \StrictByteString
bs -> forall a. a -> Maybe a
Just (StrictByteString
bs, StrictByteString -> Int
length StrictByteString
bs)

decodeNative ::
       forall a. Storable a
    => BSRead a
decodeNative :: forall a. Storable a => BSRead a
decodeNative = let
    typeSize :: Int
    typeSize :: Int
typeSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)
    in forall a.
(StrictByteString -> Maybe (StrictByteString, a)) -> BSRead a
MkBSRead forall a b. (a -> b) -> a -> b
$ \bs :: StrictByteString
bs@(BS ForeignPtr Word8
fptr Int
len) ->
           if Int
typeSize forall a. Ord a => a -> a -> Bool
<= Int
len
               then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Int -> StrictByteString -> StrictByteString
drop Int
typeSize StrictByteString
bs, forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr)
               else forall a. Maybe a
Nothing

encodeNative ::
       forall a. Storable a
    => a
    -> StrictByteString
encodeNative :: forall a. Storable a => a -> StrictByteString
encodeNative a
a = let
    typeSize :: Int
    typeSize :: Int
typeSize = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: a)
    in forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word8 -> IO ()) -> IO StrictByteString
create Int
typeSize forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> forall a. Storable a => Ptr a -> a -> IO ()
poke (forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) a
a

unsafeStorableCoerce ::
       forall a b. (Storable a, Storable b)
    => a
    -> b
unsafeStorableCoerce :: forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce a
a = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with a
a forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr -> forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr

class Storable a => FixedNumeric a where
    nativeToLittleEndian :: a -> a
    nativeToBigEndian :: a -> a

instance FixedNumeric Word8 where
    nativeToLittleEndian :: Word8 -> Word8
nativeToLittleEndian = forall a. a -> a
id
    nativeToBigEndian :: Word8 -> Word8
nativeToBigEndian = forall a. a -> a
id

instance FixedNumeric Word16 where
    nativeToLittleEndian :: Word16 -> Word16
nativeToLittleEndian = Word16 -> Word16
fromLE16
    nativeToBigEndian :: Word16 -> Word16
nativeToBigEndian = Word16 -> Word16
fromBE16

instance FixedNumeric Word32 where
    nativeToLittleEndian :: Word32 -> Word32
nativeToLittleEndian = Word32 -> Word32
fromLE32
    nativeToBigEndian :: Word32 -> Word32
nativeToBigEndian = Word32 -> Word32
fromBE32

instance FixedNumeric Word64 where
    nativeToLittleEndian :: Word64 -> Word64
nativeToLittleEndian = Word64 -> Word64
fromLE64
    nativeToBigEndian :: Word64 -> Word64
nativeToBigEndian = Word64 -> Word64
fromBE64

instance FixedNumeric Int8 where
    nativeToLittleEndian :: Int8 -> Int8
nativeToLittleEndian = forall a. a -> a
id
    nativeToBigEndian :: Int8 -> Int8
nativeToBigEndian = forall a. a -> a
id

instance FixedNumeric Int16 where
    nativeToLittleEndian :: Int16 -> Int16
nativeToLittleEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian @Word16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce
    nativeToBigEndian :: Int16 -> Int16
nativeToBigEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian @Word16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce

instance FixedNumeric Int32 where
    nativeToLittleEndian :: Int32 -> Int32
nativeToLittleEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian @Word32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce
    nativeToBigEndian :: Int32 -> Int32
nativeToBigEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian @Word32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce

instance FixedNumeric Int64 where
    nativeToLittleEndian :: Int64 -> Int64
nativeToLittleEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian @Word64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce
    nativeToBigEndian :: Int64 -> Int64
nativeToBigEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian @Word64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce

instance FixedNumeric Float where
    nativeToLittleEndian :: Float -> Float
nativeToLittleEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian @Word32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce
    nativeToBigEndian :: Float -> Float
nativeToBigEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian @Word32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce

instance FixedNumeric Double where
    nativeToLittleEndian :: Double -> Double
nativeToLittleEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian @Word64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce
    nativeToBigEndian :: Double -> Double
nativeToBigEndian = forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian @Word64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Storable a, Storable b) => a -> b
unsafeStorableCoerce

decodeLittleEndian ::
       forall a. FixedNumeric a
    => BSRead a
decodeLittleEndian :: forall a. FixedNumeric a => BSRead a
decodeLittleEndian = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FixedNumeric a => a -> a
nativeToLittleEndian forall a b. (a -> b) -> a -> b
$ forall a. Storable a => BSRead a
decodeNative

encodeLittleEndian ::
       forall a. FixedNumeric a
    => a
    -> StrictByteString
encodeLittleEndian :: forall a. FixedNumeric a => a -> StrictByteString
encodeLittleEndian = forall a. Storable a => a -> StrictByteString
encodeNative forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToLittleEndian

decodeBigEndian ::
       forall a. FixedNumeric a
    => BSRead a
decodeBigEndian :: forall a. FixedNumeric a => BSRead a
decodeBigEndian = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FixedNumeric a => a -> a
nativeToBigEndian forall a b. (a -> b) -> a -> b
$ forall a. Storable a => BSRead a
decodeNative

encodeBigEndian ::
       forall a. FixedNumeric a
    => a
    -> StrictByteString
encodeBigEndian :: forall a. FixedNumeric a => a -> StrictByteString
encodeBigEndian = forall a. Storable a => a -> StrictByteString
encodeNative forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FixedNumeric a => a -> a
nativeToBigEndian