{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance

{- | Serialization using the bytezap library.

bytezap serializers ("pokes") work by writing bytes into a pointer, which is
assumed to have _precisely_ the space required. The user must determine the
post-serialize length before the fact. For that reason, this module requires
that types to be serialized have a 'BLen' instance. In general, we are happy
about this, because a binrep type should always have an efficient and preferably
simple 'BLen' instance (and if not, it shouldn't be a binrep type).
-}

module Binrep.Put.Bytezap where

import Bytezap
import Bytezap.Poke.Bytes
import Bytezap.Poke.Int
import Data.ByteString qualified as B
import Binrep.BLen.Simple

import Binrep.Util.Class
import GHC.TypeLits ( TypeError )

import Data.Void
import Data.Word
import Data.Int

import GHC.Generics
import Generic.Data.Function.FoldMap
import Generic.Data.Function.Common
import Generic.Data.Rep.Assert

class Put a where put :: a -> Poke

runPut :: (BLen a, Put a) => a -> B.ByteString
runPut :: forall a. (BLen a, Put a) => a -> ByteString
runPut a
a = Int -> Poke -> ByteString
runPoke (a -> Int
forall a. BLen a => a -> Int
blen a
a) (a -> Poke
forall a. Put a => a -> Poke
put a
a)
{-# INLINE runPut #-}

instance GenericFoldMap Poke where
    type GenericFoldMapC Poke a = Put a
    genericFoldMapF :: forall a. GenericFoldMapC Poke a => a -> Poke
genericFoldMapF = a -> Poke
forall a. Put a => a -> Poke
put

-- | Serialize a term of the non-sum type @a@ via its 'Generic' instance.
putGenericNonSum
    :: forall {cd} {f} {asserts} a
    .  ( Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Poke f
       , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f)
    => a -> Poke
putGenericNonSum :: forall {cd :: Meta} {f :: Type -> Type} {asserts :: [GCAssert]} a.
(Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Poke f,
 asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) =>
a -> Poke
putGenericNonSum = forall (asserts :: [GCAssert]) m a.
(Generic a, Rep a ~ D1 cd f, GFoldMapNonSum m f,
 ApplyGCAsserts asserts f) =>
a -> m
forall {cd :: Meta} {f :: Type -> Type} (asserts :: [GCAssert]) m
       a.
(Generic a, Rep a ~ D1 cd f, GFoldMapNonSum m f,
 ApplyGCAsserts asserts f) =>
a -> m
genericFoldMapNonSum @asserts

-- | Serialize a term of the sum type @a@ via its 'Generic' instance.
--
-- You must provide a serializer for @a@'s constructors. This is regrettably
-- inefficient due to having to use 'String's. Alas. Do write your own instance
-- if you want better performance!
putGenericSum
    :: forall {cd} {f} {asserts} a
    .  (Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Poke f
       , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f)
    => (String -> Poke) -> a -> Poke
putGenericSum :: forall {cd :: Meta} {f :: Type -> Type} {asserts :: [GCAssert]} a.
(Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Poke f,
 asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) =>
(String -> Poke) -> a -> Poke
putGenericSum = forall {cd :: Meta} {f :: Type -> Type} (opts :: SumOpts)
       (asserts :: [GCAssert]) m a.
(Generic a, Rep a ~ D1 cd f, GFoldMapSum opts m f,
 ApplyGCAsserts asserts f) =>
(String -> m) -> a -> m
forall (opts :: SumOpts) (asserts :: [GCAssert]) m a.
(Generic a, Rep a ~ D1 cd f, GFoldMapSum opts m f,
 ApplyGCAsserts asserts f) =>
(String -> m) -> a -> m
genericFoldMapSum @'SumOnly @asserts

instance TypeError ENoEmpty => Put Void where put :: Void -> Poke
put = Void -> Poke
forall a. HasCallStack => a
undefined
instance TypeError ENoSum => Put (Either a b) where put :: Either a b -> Poke
put = Either a b -> Poke
forall a. HasCallStack => a
undefined

instance Put Write where
    {-# INLINE put #-}
    put :: Write -> Poke
put = Write -> Poke
writePoke

-- | Fairly useless because 'Poke' doesn't have a 'BLen' instance.
instance Put Poke where
    {-# INLINE put #-}
    put :: Poke -> Poke
put = Poke -> Poke
forall a. a -> a
id

-- | Unit type serializes to nothing. How zen.
instance Put () where
    {-# INLINE put #-}
    put :: () -> Poke
put = () -> Poke
forall a. Monoid a => a
mempty

instance (Put l, Put r) => Put (l, r) where
    {-# INLINE put #-}
    put :: (l, r) -> Poke
put (l
l, r
r) = l -> Poke
forall a. Put a => a -> Poke
put l
l Poke -> Poke -> Poke
forall a. Semigroup a => a -> a -> a
<> r -> Poke
forall a. Put a => a -> Poke
put r
r

instance Put a => Put [a] where
    {-# INLINE put #-}
    put :: [a] -> Poke
put = [Poke] -> Poke
forall a. Monoid a => [a] -> a
mconcat ([Poke] -> Poke) -> ([a] -> [Poke]) -> [a] -> Poke
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Poke) -> [a] -> [Poke]
forall a b. (a -> b) -> [a] -> [b]
map a -> Poke
forall a. Put a => a -> Poke
put

instance Put B.ByteString where
    {-# INLINE put #-}
    put :: ByteString -> Poke
put = ByteString -> Poke
byteString

instance Put Word8 where
    {-# INLINE put #-}
    put :: Word8 -> Poke
put = Word8 -> Poke
w8

instance Put Int8  where
    {-# INLINE put #-}
    put :: Int8 -> Poke
put = Int8 -> Poke
i8