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

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

import Development.Shake.Classes
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.Semigroup
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
    }

binaryOpMap :: BinaryEx a => (a -> BinaryOp b) -> BinaryOp (a, b)
binaryOpMap :: (a -> BinaryOp b) -> BinaryOp (a, b)
binaryOpMap a -> BinaryOp b
mp = BinaryOp :: forall v. (v -> Builder) -> (ByteString -> v) -> BinaryOp v
BinaryOp
    {putOp :: (a, b) -> Builder
putOp = \(a
a, b
b) -> Builder -> Builder
putExN (a -> Builder
forall a. BinaryEx a => a -> Builder
putEx a
a) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> BinaryOp b -> b -> Builder
forall v. BinaryOp v -> v -> Builder
putOp (a -> BinaryOp b
mp a
a) b
b
    ,getOp :: ByteString -> (a, b)
getOp = \ByteString
bs -> let (ByteString
bs1,ByteString
bs2) = ByteString -> (ByteString, ByteString)
getExN ByteString
bs; a :: a
a = ByteString -> a
forall a. BinaryEx a => ByteString -> a
getEx ByteString
bs1 in (a
a, BinaryOp b -> ByteString -> b
forall v. BinaryOp v -> ByteString -> v
getOp (a -> BinaryOp b
mp a
a) ByteString
bs2)
    }


binarySplit :: forall a . Storable a => BS.ByteString -> (a, BS.ByteString)
binarySplit :: ByteString -> (a, ByteString)
binarySplit 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 [Char]
"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 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 [Char]
"Reading from ByteString, insufficient left"
                | (a
a,ByteString
bs) <- ByteString -> (a, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (b
b,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 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 [Char]
"Reading from ByteString, insufficient left"
                | (a
a,ByteString
bs) <- ByteString -> (a, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (b
b,ByteString
bs) <- ByteString -> (b, ByteString)
forall a. Storable a => ByteString -> (a, ByteString)
unsafeBinarySplit ByteString
bs, (c
c,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 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
$ \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_ [a]
as [b]
bs 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 Int
i forall a. Ptr a -> Int -> IO ()
_) = Int
i

runBuilder :: Builder -> BS.ByteString
runBuilder :: Builder -> ByteString
runBuilder (Builder Int
i 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 Word8
ptr -> Ptr Word8 -> Int -> IO ()
forall a. Ptr a -> Int -> IO ()
f Ptr Word8
ptr Int
0

instance Semigroup Builder where
    (Builder Int
x1 forall a. Ptr a -> Int -> IO ()
x2) <> :: Builder -> Builder -> Builder
<> (Builder Int
y1 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
$ \Ptr a
p 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 Int
0 ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr a
_ Int
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    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 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 a
ptr 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
$ \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 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 a
ptr Int
i -> do
        let go :: Int -> [ByteString] -> IO ()
go Int
_ [] = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            go Int
i (ByteString
x:[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
$ \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 (f :: * -> *) a. Applicative f => a -> f a
pure

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 [ByteString]
xs = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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
$ \Ptr a
p 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_ [Int
4Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i,Int
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
$ \Int
i 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 (f :: * -> *) a. Applicative f => a -> f a
pure (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
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
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
(+) Int
0 [Int]
ns) [ByteString]
xs ((Int -> ByteString -> IO ()) -> IO ())
-> (Int -> ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i 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
$ \(CString
bs, 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 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
$ \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 Int
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 [Int
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
$ \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
* Int
4)
        [ByteString] -> IO [ByteString]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([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 (\ByteString
bs 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 (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)) ByteString
bs) [Word32]
ns

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

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 Maybe [Char]
Nothing = Builder
forall a. Monoid a => a
mempty
    putEx (Just [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
$ Char
'\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 ([Char]
a,[[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 ByteString
x = let [Char]
a:[[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 Bool
False = Int -> (forall a. Ptr a -> Int -> IO ()) -> Builder
Builder Int
1 ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr a
ptr Int
i -> Ptr a -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr a
ptr Int
i (Word8
0 :: Word8)
    putEx Bool
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 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
$ \Ptr a
p 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 = \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
$ \(CString
p, 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 [Char]
"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 [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 a
ptr 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
$ \Int
i 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 = \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
$ \(CString
p, Int
size) ->
    let (Int
d,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
/= Int
0 then [Char] -> IO [a]
forall a. HasCallStack => [Char] -> a
error [Char]
"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 [Int
0..Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1] ((Int -> IO a) -> IO [a]) -> (Int -> IO a) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \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 [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 (\Builder
b -> Builder -> Int
sizeBuilder Builder
b Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) [Builder]
xs) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr a
p Int
i -> do
    let go :: Int -> [Builder] -> IO ()
go Int
_ [] = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        go Int
i (Builder Int
n forall a. Ptr a -> Int -> IO ()
b:[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
+Int
4)
            Int -> [Builder] -> IO ()
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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 ByteString
bs
    | Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = []
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
    , (Word32
n :: Word32, 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
- Int
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 [Char]
"getList, corrupted binary"
    where len :: Int
len = ByteString -> Int
BS.length ByteString
bs

putExN :: Builder -> Builder
putExN :: Builder -> Builder
putExN (Builder Int
n 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
+Int
4) ((forall a. Ptr a -> Int -> IO ()) -> Builder)
-> (forall a. Ptr a -> Int -> IO ()) -> Builder
forall a b. (a -> b) -> a -> b
$ \Ptr a
p 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
+Int
4

getExN :: BS.ByteString -> (BS.ByteString, BS.ByteString)
getExN :: ByteString -> (ByteString, ByteString)
getExN ByteString
bs
    | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4
    , (Word32
n :: Word32, 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
- Int
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 [Char]
"getList, corrupted binary"
    where len :: Int
len = ByteString -> Int
BS.length ByteString
bs