{-# LANGUAGE FlexibleInstances, ExplicitForAll, ScopedTypeVariables, Rank2Types #-}

module General.Binary(
    BinaryOp(..),
    binarySplit, binarySplit2, binarySplit3, unsafeBinarySplit,
    Builder(..), runBuilder, sizeBuilder,
    BinaryEx(..),
    putExStorable, getExStorable, putExStorableList, getExStorableList,
    putExList, getExList, putExN, getExN
    ) where

import Control.Monad
import Data.Binary
import Data.List.Extra
import Data.Tuple.Extra
import Foreign.Storable
import Foreign.Ptr
import System.IO.Unsafe as U
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.UTF8 as UTF8
import Data.Functor
import Data.Semigroup (Semigroup (..))
import Data.Monoid hiding ((<>))
import Prelude


---------------------------------------------------------------------
-- STORE TYPE

-- | An explicit and more efficient version of Binary
data BinaryOp v = BinaryOp
    {BinaryOp v -> v -> Builder
putOp :: v -> Builder
    ,BinaryOp v -> ByteString -> v
getOp :: BS.ByteString -> v
    }

binarySplit :: forall a . Storable a => BS.ByteString -> (a, BS.ByteString)
binarySplit :: ByteString -> (a, ByteString)
binarySplit bs :: ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a) = [Char] -> (a, ByteString)
forall a. HasCallStack => [Char] -> a
error "Reading from ByteString, insufficient left"
               | Bool
otherwise = ByteString -> (a, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs

binarySplit2 :: forall a b . (Storable a, Storable b) => BS.ByteString -> (a, b, BS.ByteString)
binarySplit2 :: ByteString -> (a, b, ByteString)
binarySplit2 bs :: ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ b -> Int
forall a. Storable a => a -> Int
sizeOf (b
forall a. HasCallStack => a
undefined :: b) = [Char] -> (a, b, ByteString)
forall a. HasCallStack => [Char] -> a
error "Reading from ByteString, insufficient left"
                | (a :: a
a,bs :: ByteString
bs) <- ByteString -> (a, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (b :: b
b,bs :: ByteString
bs) <- ByteString -> (b, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs = (a
a,b
b,ByteString
bs)

binarySplit3 :: forall a b c . (Storable a, Storable b, Storable c) => BS.ByteString -> (a, b, c, BS.ByteString)
binarySplit3 :: ByteString -> (a, b, c, ByteString)
binarySplit3 bs :: ByteString
bs | ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ b -> Int
forall a. Storable a => a -> Int
sizeOf (b
forall a. HasCallStack => a
undefined :: b) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ c -> Int
forall a. Storable a => a -> Int
sizeOf (c
forall a. HasCallStack => a
undefined :: c) = [Char] -> (a, b, c, ByteString)
forall a. HasCallStack => [Char] -> a
error "Reading from ByteString, insufficient left"
                | (a :: a
a,bs :: ByteString
bs) <- ByteString -> (a, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (b :: b
b,bs :: ByteString
bs) <- ByteString -> (b, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (c :: c
c,bs :: ByteString
bs) <- ByteString -> (c, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs = (a
a,b
b,c
c,ByteString
bs)


unsafeBinarySplit :: Storable a => BS.ByteString -> (a, BS.ByteString)
unsafeBinarySplit :: ByteString -> (a, ByteString)
unsafeBinarySplit bs :: ByteString
bs = (a
v, Int -> ByteString -> ByteString
BS.unsafeDrop (a -> Int
forall a. Storable a => a -> Int
sizeOf a
v) ByteString
bs)
    where v :: a
v = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> (CString -> IO a) -> IO a
forall a. ByteString -> (CString -> IO a) -> IO a
BS.unsafeUseAsCString ByteString
bs ((CString -> IO a) -> IO a) -> (CString -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ptr :: CString
ptr -> Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (CString -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr CString
ptr)


-- forM for zipWith
for2M_ :: [a] -> [b] -> (a -> b -> m c) -> m ()
for2M_ as :: [a]
as bs :: [b]
bs f :: a -> b -> m c
f = (a -> b -> m c) -> [a] -> [b] -> m ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ a -> b -> m c
f [a]
as [b]
bs

---------------------------------------------------------------------
-- BINARY SERIALISATION

-- We can't use the Data.ByteString builder as that doesn't track the size of the chunk.
data Builder = Builder {-# UNPACK #-} !Int (forall a . Ptr a -> Int -> IO ())

sizeBuilder :: Builder -> Int
sizeBuilder :: Builder -> Int
sizeBuilder (Builder i :: Int
i _) = Int
i

runBuilder :: Builder -> BS.ByteString
runBuilder :: Builder -> ByteString
runBuilder (Builder i :: Int
i f :: forall a. Ptr a -> Int -> IO ()
f) = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word8 -> IO ()) -> IO ByteString
BS.create Int
i ((Ptr Word8 -> IO ()) -> IO ByteString)
-> (Ptr Word8 -> IO ()) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr Word8
ptr -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
f Ptr Word8
ptr 0

instance Semigroup Builder where
    (Builder x1 :: Int
x1 x2 :: forall a. Ptr a -> Int -> IO ()
x2) <> :: Builder -> Builder -> Builder
<> (Builder y1 :: Int
y1 y2 :: forall a. Ptr a -> Int -> IO ()
y2) = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (Int
x1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
y1) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \p :: Ptr a
p i :: Int
i -> do Ptr a -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
x2 Ptr a
p Int
i; Ptr a -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
y2 Ptr a
p (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
x1

instance Monoid Builder where
    mempty :: Builder
mempty = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder 0 ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \_ _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    mappend :: Builder -> Builder -> Builder
mappend = Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
(<>)

-- | Methods for Binary serialisation that go directly between strict ByteString values.
--   When the Database is read each key/value will be loaded as a separate ByteString,
--   and for certain types (e.g. file rules) this may remain the preferred format for storing keys.
--   Optimised for performance.
class BinaryEx a where
    putEx :: a -> Builder
    getEx :: BS.ByteString -> a

instance BinaryEx BS.ByteString where
    putEx :: ByteString -> Builder
putEx x :: ByteString
x = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder Int
n ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr i :: Int
i -> ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
x ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bs :: CString
bs -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy (Ptr a
ptr Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
i) (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
bs) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        where n :: Int
n = ByteString -> Int
BS.length ByteString
x
    getEx :: ByteString -> ByteString
getEx = ByteString -> ByteString
forall a. a -> a
id

instance BinaryEx LBS.ByteString where
    putEx :: ByteString -> Builder
putEx x :: ByteString
x = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Int) -> Int64 -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length ByteString
x) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr i :: Int
i -> do
        let go :: Int -> [ByteString] -> IO ()
go i :: Int
i [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            go i :: Int
i (x :: ByteString
x:xs :: [ByteString]
xs) = do
                let n :: Int
n = ByteString -> Int
BS.length ByteString
x
                ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
x ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \bs :: CString
bs -> Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy (Ptr a
ptr Ptr a -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
i) (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
bs) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
                Int -> [ByteString] -> IO ()
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) [ByteString]
xs
        Int -> [ByteString] -> IO ()
go Int
i ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
LBS.toChunks ByteString
x
    getEx :: ByteString -> ByteString
getEx = [ByteString] -> ByteString
LBS.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return

instance BinaryEx [BS.ByteString] where
    -- Format:
    -- n :: Word32 - number of strings
    -- ns :: [Word32]{n} - length of each string
    -- contents of each string concatenated (sum ns bytes)
    putEx :: [ByteString] -> Builder
putEx xs :: [ByteString]
xs = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
ns) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \p :: Ptr a
p i :: Int
i -> do
        Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
i (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word32)
        [Int] -> [Int] -> (Int -> Int -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
[a] -> [b] -> (a -> b -> m c) -> m ()
for2M_ [4Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i,8Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i..] [Int]
ns ((Int -> Int -> IO ()) -> IO ()) -> (Int -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i :: Int
i x :: Int
x -> Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
i (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x :: Word32)
        Ptr Any
p <- Ptr Any -> IO (Ptr Any)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Any -> IO (Ptr Any)) -> Ptr Any -> IO (Ptr Any)
forall a b. (a -> b) -> a -> b
$ Ptr a
p Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4))
        [Int] -> [ByteString] -> (Int -> ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
[a] -> [b] -> (a -> b -> m c) -> m ()
for2M_ ((Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) 0 [Int]
ns) [ByteString]
xs ((Int -> ByteString -> IO ()) -> IO ())
-> (Int -> ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i :: Int
i x :: ByteString
x -> ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
x ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(bs :: CString
bs, n :: Int
n) ->
            Ptr Word8 -> Ptr Word8 -> Int -> IO ()
BS.memcpy (Ptr Any
p Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
i) (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
bs) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
        where ns :: [Int]
ns = (ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Int
BS.length [ByteString]
xs
              n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ns

    getEx :: ByteString -> [ByteString]
getEx bs :: ByteString
bs = IO [ByteString] -> [ByteString]
forall a. IO a -> a
unsafePerformIO (IO [ByteString] -> [ByteString])
-> IO [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> (CString -> IO [ByteString]) -> IO [ByteString]
forall a. ByteString -> (CString -> IO a) -> IO a
BS.useAsCString ByteString
bs ((CString -> IO [ByteString]) -> IO [ByteString])
-> (CString -> IO [ByteString]) -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \p :: CString
p -> do
        Int
n <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> IO Word32 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CString -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff CString
p 0 :: IO Word32)
        [Word32]
ns :: [Word32] <- [Int] -> (Int -> IO Word32) -> IO [Word32]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [1..Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n] ((Int -> IO Word32) -> IO [Word32])
-> (Int -> IO Word32) -> IO [Word32]
forall a b. (a -> b) -> a -> b
$ \i :: Int
i -> CString -> Int -> IO Word32
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff CString
p (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4)
        [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ (ByteString, [ByteString]) -> [ByteString]
forall a b. (a, b) -> b
snd ((ByteString, [ByteString]) -> [ByteString])
-> (ByteString, [ByteString]) -> [ByteString]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Word32 -> (ByteString, ByteString))
-> ByteString -> [Word32] -> (ByteString, [ByteString])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL (\bs :: ByteString
bs i :: Word32
i -> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a, b) -> (b, a)
swap ((ByteString, ByteString) -> (ByteString, ByteString))
-> (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
i) ByteString
bs) (Int -> ByteString -> ByteString
BS.drop (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* 4)) ByteString
bs) [Word32]
ns

instance BinaryEx () where
    putEx :: () -> Builder
putEx () = Builder
forall a. Monoid a => a
mempty
    getEx :: ByteString -> ()
getEx _ = ()

instance BinaryEx String where
    putEx :: [Char] -> Builder
putEx = ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx (ByteString -> Builder)
-> ([Char] -> ByteString) -> [Char] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
UTF8.fromString
    getEx :: ByteString -> [Char]
getEx = ByteString -> [Char]
UTF8.toString

instance BinaryEx (Maybe String) where
    putEx :: Maybe [Char] -> Builder
putEx Nothing = Builder
forall a. Monoid a => a
mempty
    putEx (Just xs :: [Char]
xs) = ByteString -> Builder
forall a. BinaryEx a => a -> Builder
putEx (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ [Char] -> ByteString
UTF8.fromString ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ '\0' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs
    getEx :: ByteString -> Maybe [Char]
getEx = ((Char, [Char]) -> [Char]) -> Maybe (Char, [Char]) -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char, [Char]) -> [Char]
forall a b. (a, b) -> b
snd (Maybe (Char, [Char]) -> Maybe [Char])
-> (ByteString -> Maybe (Char, [Char]))
-> ByteString
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe (Char, [Char])
forall a. [a] -> Maybe (a, [a])
uncons ([Char] -> Maybe (Char, [Char]))
-> (ByteString -> [Char]) -> ByteString -> Maybe (Char, [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
UTF8.toString

instance BinaryEx [String] where
    putEx :: [[Char]] -> Builder
putEx = [ByteString] -> Builder
forall a. BinaryEx a => a -> Builder
putEx ([ByteString] -> Builder)
-> ([[Char]] -> [ByteString]) -> [[Char]] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> ByteString) -> [[Char]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> ByteString
UTF8.fromString
    getEx :: ByteString -> [[Char]]
getEx = (ByteString -> [Char]) -> [ByteString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> [Char]
UTF8.toString ([ByteString] -> [[Char]])
-> (ByteString -> [ByteString]) -> ByteString -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall a. BinaryEx a => ByteString -> a
getEx

instance BinaryEx (String, [String]) where
    putEx :: ([Char], [[Char]]) -> Builder
putEx (a :: [Char]
a,bs :: [[Char]]
bs) = [[Char]] -> Builder
forall a. BinaryEx a => a -> Builder
putEx ([[Char]] -> Builder) -> [[Char]] -> Builder
forall a b. (a -> b) -> a -> b
$ [Char]
a[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
bs
    getEx :: ByteString -> ([Char], [[Char]])
getEx x :: ByteString
x = let a :: [Char]
a:bs :: [[Char]]
bs = ByteString -> [[Char]]
forall a. BinaryEx a => ByteString -> a
getEx ByteString
x in ([Char]
a,[[Char]]
bs)

instance BinaryEx Bool where
    putEx :: Bool -> Builder
putEx False = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder 1 ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr i :: Int
i -> Ptr a -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
ptr Int
i (0 :: Word8)
    putEx True = Builder
forall a. Monoid a => a
mempty
    getEx :: ByteString -> Bool
getEx = ByteString -> Bool
BS.null

instance BinaryEx Word8 where
    putEx :: Word8 -> Builder
putEx = Word8 -> Builder
forall a. Storable a => a -> Builder
putExStorable
    getEx :: ByteString -> Word8
getEx = ByteString -> Word8
forall a. Storable a => ByteString -> a
getExStorable

instance BinaryEx Word16 where
    putEx :: Word16 -> Builder
putEx = Word16 -> Builder
forall a. Storable a => a -> Builder
putExStorable
    getEx :: ByteString -> Word16
getEx = ByteString -> Word16
forall a. Storable a => ByteString -> a
getExStorable

instance BinaryEx Word32 where
    putEx :: Word32 -> Builder
putEx = Word32 -> Builder
forall a. Storable a => a -> Builder
putExStorable
    getEx :: ByteString -> Word32
getEx = ByteString -> Word32
forall a. Storable a => ByteString -> a
getExStorable

instance BinaryEx Int where
    putEx :: Int -> Builder
putEx = Int -> Builder
forall a. Storable a => a -> Builder
putExStorable
    getEx :: ByteString -> Int
getEx = ByteString -> Int
forall a. Storable a => ByteString -> a
getExStorable

instance BinaryEx Float where
    putEx :: Float -> Builder
putEx = Float -> Builder
forall a. Storable a => a -> Builder
putExStorable
    getEx :: ByteString -> Float
getEx = ByteString -> Float
forall a. Storable a => ByteString -> a
getExStorable


putExStorable :: forall a . Storable a => a -> Builder
putExStorable :: a -> Builder
putExStorable x :: a
x = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (a -> Int
forall a. Storable a => a -> Int
sizeOf a
x) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \p :: Ptr a
p i :: Int
i -> Ptr a -> Int -> a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
i a
x

getExStorable :: forall a . Storable a => BS.ByteString -> a
getExStorable :: ByteString -> a
getExStorable = \bs :: ByteString
bs -> IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO a) -> IO a
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
bs ((CStringLen -> IO a) -> IO a) -> (CStringLen -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(p :: CString
p, size :: Int
size) ->
        if Int
size Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n then [Char] -> IO a
forall a. HasCallStack => [Char] -> a
error "size mismatch" else Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek (CString -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr CString
p)
    where n :: Int
n = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)


putExStorableList :: forall a . Storable a => [a] -> Builder
putExStorableList :: [a] -> Builder
putExStorableList xs :: [a]
xs = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \ptr :: Ptr a
ptr i :: Int
i ->
    [Int] -> [a] -> (Int -> a -> IO ()) -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
[a] -> [b] -> (a -> b -> m c) -> m ()
for2M_ [Int
i,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n..] [a]
xs ((Int -> a -> IO ()) -> IO ()) -> (Int -> a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \i :: Int
i x :: a
x -> Ptr a -> Int -> a -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
ptr Int
i a
x
    where n :: Int
n = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)

getExStorableList :: forall a . Storable a => BS.ByteString -> [a]
getExStorableList :: ByteString -> [a]
getExStorableList = \bs :: ByteString
bs -> IO [a] -> [a]
forall a. IO a -> a
unsafePerformIO (IO [a] -> [a]) -> IO [a] -> [a]
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO [a]) -> IO [a]
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BS.useAsCStringLen ByteString
bs ((CStringLen -> IO [a]) -> IO [a])
-> (CStringLen -> IO [a]) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \(p :: CString
p, size :: Int
size) ->
    let (d :: Int
d,m :: Int
m) = Int
size Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
n in
    if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 then [Char] -> IO [a]
forall a. HasCallStack => [Char] -> a
error "size mismatch" else [Int] -> (Int -> IO a) -> IO [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0..Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-1] ((Int -> IO a) -> IO [a]) -> (Int -> IO a) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \i :: Int
i -> Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (CString -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr CString
p) Int
i
    where n :: Int
n = a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)


-- repeating:
--     Word32, length of BS
--     BS
putExList :: [Builder] -> Builder
putExList :: [Builder] -> Builder
putExList xs :: [Builder]
xs = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Builder -> Int) -> [Builder] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\b :: Builder
b -> Builder -> Int
sizeBuilder Builder
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4) [Builder]
xs) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \p :: Ptr a
p i :: Int
i -> do
    let go :: Int -> [Builder] -> IO ()
go i :: Int
i [] = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go i :: Int
i (Builder n :: Int
n b :: forall a. Ptr a -> Int -> IO ()
b:xs :: [Builder]
xs) = do
            Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
i (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word32)
            Ptr a -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
b Ptr a
p (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+4)
            Int -> [Builder] -> IO ()
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+4Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) [Builder]
xs
    Int -> [Builder] -> IO ()
go Int
i [Builder]
xs

getExList :: BS.ByteString -> [BS.ByteString]
getExList :: ByteString -> [ByteString]
getExList bs :: ByteString
bs
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = []
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4
    , (Word32
n :: Word32, bs :: ByteString
bs) <- ByteString -> (Word32, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs
    , Int
n <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n
    , (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
    = Int -> ByteString -> ByteString
BS.unsafeTake Int
n ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
getExList (Int -> ByteString -> ByteString
BS.unsafeDrop Int
n ByteString
bs)
    | Bool
otherwise = [Char] -> [ByteString]
forall a. HasCallStack => [Char] -> a
error "getList, corrupted binary"
    where len :: Int
len = ByteString -> Int
BS.length ByteString
bs

putExN :: Builder -> Builder
putExN :: Builder -> Builder
putExN (Builder n :: Int
n old :: forall a. Ptr a -> Int -> IO ()
old) = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+4) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \p :: Ptr a
p i :: Int
i -> do
    Ptr a -> Int -> Word32 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
p Int
i (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word32)
    Ptr a -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
old Ptr a
p (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+4

getExN :: BS.ByteString -> (BS.ByteString, BS.ByteString)
getExN :: ByteString -> (ByteString, ByteString)
getExN bs :: ByteString
bs
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4
    , (Word32
n :: Word32, bs :: ByteString
bs) <- ByteString -> (Word32, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs
    , Int
n <- Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n
    , (Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n
    = (Int -> ByteString -> ByteString
BS.unsafeTake Int
n ByteString
bs, Int -> ByteString -> ByteString
BS.unsafeDrop Int
n ByteString
bs)
    | Bool
otherwise = [Char] -> (ByteString, ByteString)
forall a. HasCallStack => [Char] -> a
error "getList, corrupted binary"
    where len :: Int
len = ByteString -> Int
BS.length ByteString
bs