{-# OPTIONS_GHC -fno-warn-orphans #-} -- for generic data op instance

-- TODO some instances are wrong, Void should be typeerror

module Binrep.Put.Mason where

import Mason.Builder qualified as Mason

import Data.ByteString qualified as B

import Data.Word
import Data.Int
import Data.Void ( Void, absurd )

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

type Builder = Mason.BuilderFor Mason.StrictByteStringBackend

class Put a where
    -- | Serialize to binary.
    put :: a -> Builder

-- | Run the serializer.
runPut :: Put a => a -> B.ByteString
runPut :: forall a. Put a => a -> ByteString
runPut = Builder -> ByteString
runBuilder (Builder -> ByteString) -> (a -> Builder) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Put a => a -> Builder
put

runBuilder :: Builder -> B.ByteString
runBuilder :: Builder -> ByteString
runBuilder = Builder -> ByteString
Mason.toStrictByteString

instance GenericFoldMap Builder where
    type GenericFoldMapC Builder a = Put a
    genericFoldMapF :: forall a. GenericFoldMapC Builder a => a -> Builder
genericFoldMapF = a -> Builder
forall a. Put a => a -> Builder
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 Builder f
       , asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f)
    => a -> Builder
putGenericNonSum :: forall {cd :: Meta} {f :: Type -> Type} {asserts :: [GCAssert]} a.
(Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Builder f,
 asserts ~ '[ 'NoEmpty, 'NoSum], ApplyGCAsserts asserts f) =>
a -> Builder
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 Builder f
       , asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f)
    => (String -> Builder) -> a -> Builder
putGenericSum :: forall {cd :: Meta} {f :: Type -> Type} {asserts :: [GCAssert]} a.
(Generic a, Rep a ~ D1 cd f, GFoldMapSum 'SumOnly Builder f,
 asserts ~ '[ 'NoEmpty, 'NeedSum], ApplyGCAsserts asserts f) =>
(String -> Builder) -> a -> Builder
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

-- | Impossible to serialize 'Void'.
instance Put Void where
    put :: Void -> Builder
put = Void -> Builder
forall a. Void -> a
absurd

-- | Serialize each element in order. No length indicator, so parse until either
--   error or EOF. Usually not what you want, but sometimes used at the "top" of
--   binary formats.
instance Put a => Put [a] where
    put :: [a] -> Builder
put = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> ([a] -> [Builder]) -> [a] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Builder) -> [a] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map a -> Builder
forall a. Put a => a -> Builder
put

instance (Put a, Put b) => Put (a, b) where
    put :: (a, b) -> Builder
put (a
a, b
b) = a -> Builder
forall a. Put a => a -> Builder
put a
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> b -> Builder
forall a. Put a => a -> Builder
put b
b

-- | Serialize the bytestring as-is.
--
-- Careful -- the only way you're going to be able to parse this is to read
-- until EOF.
instance Put B.ByteString where
    put :: ByteString -> Builder
put = ByteString -> Builder
forall s. Buildable s => ByteString -> BuilderFor s
Mason.byteString
    {-# INLINE put #-}

-- need to give args for RankNTypes reasons I don't understand
instance Put Word8 where
    put :: Word8 -> Builder
put Word8
w = Word8 -> Builder
Mason.word8 Word8
w
    {-# INLINE put #-}
instance Put  Int8 where
    put :: Int8 -> Builder
put Int8
w = Int8 -> Builder
Mason.int8 Int8
w
    {-# INLINE put #-}

-- | Put with inlined checks via an environment.
class PutWith r a where
    -- | Attempt to serialize to binary with the given environment.
    putWith :: r -> a -> Either String Builder
    default putWith :: Put a => r -> a -> Either String Builder
    putWith r
_ = a -> Either String Builder
forall a. Put a => a -> Either String Builder
putWithout

-- | Helper for wrapping a 'BinRep' into a 'BinRepWith' (for encoding).
putWithout :: Put a => a -> Either String Builder
putWithout :: forall a. Put a => a -> Either String Builder
putWithout = Builder -> Either String Builder
forall a b. b -> Either a b
Right (Builder -> Either String Builder)
-> (a -> Builder) -> a -> Either String Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Builder
forall a. Put a => a -> Builder
put

instance Put a => PutWith r [a]

-- | Run the serializer with the given environment.
runPutWith :: PutWith r a => r -> a -> Either String B.ByteString
runPutWith :: forall r a. PutWith r a => r -> a -> Either String ByteString
runPutWith r
r a
a = case r -> a -> Either String Builder
forall r a. PutWith r a => r -> a -> Either String Builder
putWith r
r a
a of Left  String
e -> String -> Either String ByteString
forall a b. a -> Either a b
Left String
e
                                     Right Builder
x -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
runBuilder Builder
x