module Binrep.Codec where

import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as BL
import Data.ByteString.Builder qualified as B
import Data.Serialize

-- | Types that can be coded precisely between binary and a Haskell type.
--
-- This class looks identical to cereal's 'Serialize', but we take a different
-- approach to instances.
--
-- 'Data.Serialize.Serialize' defines an internal binary codec for common
-- Haskell types. It makes implicit decisions, such as big-endian for all
-- integer types, and coding lists with a (big-endian) 'Word64' length prefix.
-- It only works with other data serialized with the same library.
--
-- This typeclass defines composable binary codec combinators. If you want to
-- write a codec for a 'Word64', it needs to specify its endianness in the type.
-- If you want to write a codec for a list with a 'Word8' length prefix, it must
-- come with a proof that it's not oversized.
--
-- The idea is to use this typeclass along with various annotated newtypes to
-- allow defining a Haskell type's binary representation directly in the types.
-- In cases where you're doing intermediate serialization and not much else, it
-- may be convenient. You will need to do a bunch of (free at runtime) wrapping
-- though.
class BinaryCodec a where
    toBin   :: Putter a     -- ^ Encode to   binary. Same as cereal's 'put'.
    fromBin :: Get a        -- ^ Decode from binary. Same as cereal's 'get'.

-- | Run the encoder for a supporting type.
binEncode :: BinaryCodec a => a -> BS.ByteString
binEncode :: forall a. BinaryCodec a => a -> ByteString
binEncode = Put -> ByteString
runPut (Put -> ByteString) -> (a -> Put) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall a. BinaryCodec a => Putter a
toBin

-- | Run the decoder a supporting type.
binDecode :: BinaryCodec a => BS.ByteString -> Either String a
binDecode :: forall a. BinaryCodec a => ByteString -> Either String a
binDecode = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet Get a
forall a. BinaryCodec a => Get a
fromBin

-- | 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 BinaryCodec a => BinaryCodec [a] where
    toBin :: Putter [a]
toBin [a]
as = (a -> Put) -> Putter [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall a. BinaryCodec a => Putter a
toBin [a]
as
    fromBin :: Get [a]
fromBin = [a] -> Get [a]
forall {a}. BinaryCodec a => [a] -> Get [a]
go []
      where
        go :: [a] -> Get [a]
go [a]
as = do
            a
a <- Get a
forall a. BinaryCodec a => Get a
fromBin
            Get Bool
isEmpty Get Bool -> (Bool -> Get [a]) -> Get [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
True -> [a] -> Get [a]
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Get [a]) -> [a] -> Get [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as
              Bool
False -> [a] -> Get [a]
go ([a] -> Get [a]) -> [a] -> Get [a]
forall a b. (a -> b) -> a -> b
$ a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as

-- | Types that can be coded between binary and a Haskell type given some
--   runtime information.
--
-- We can't prove something related to a value and pass that proof along without
-- dependent types, meaning we can't split validation from encoding like in
-- 'BinaryCodec', so encoding can fail. However, by allowing an arbitrary
-- environment, we can define many more convenient instances.
--
-- For example, you can't write a 'BinaryCodec' instance for 'Word16' because it
-- doesn't specify its endianness. But you can define 'BinaryCodecWith
-- Endianness Word16'! This was, you can decide how much of the binary schema
-- you want to place directly in the types, and how much to configure
-- dynamically.
--
-- This class defaults to the free implementation provided by 'BinaryCodec',
-- which ignores the environment and wraps serializing with 'Right'.
class BinaryCodecWith r a where
    -- | Encode to binary with the given environment.
    toBinWith   :: r -> a -> Either String B.Builder
    default toBinWith :: BinaryCodec a => r -> a -> Either String B.Builder
    toBinWith = (a -> Either String Builder) -> r -> a -> Either String Builder
forall a b. a -> b -> a
const ((a -> Either String Builder) -> r -> a -> Either String Builder)
-> (a -> Either String Builder) -> r -> a -> Either String Builder
forall a b. (a -> b) -> a -> b
$ 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
. Put -> Builder
forall a. PutM a -> Builder
execPut (Put -> Builder) -> (a -> Put) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Put
forall a. BinaryCodec a => Putter a
toBin

    -- | Decode to binary with the given environment.
    fromBinWith :: r -> Get a
    default fromBinWith :: BinaryCodec a => r -> Get a
    fromBinWith = Get a -> r -> Get a
forall a b. a -> b -> a
const Get a
forall a. BinaryCodec a => Get a
fromBin

-- | Run the encoder for a supporting type using the given environment.
binEncodeWith :: BinaryCodecWith r a => r -> a -> Either String BS.ByteString
binEncodeWith :: forall r a.
BinaryCodecWith r a =>
r -> a -> Either String ByteString
binEncodeWith r
r a
a = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString (Builder -> ByteString)
-> Either String Builder -> Either String ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> r -> a -> Either String Builder
forall r a. BinaryCodecWith r a => r -> a -> Either String Builder
toBinWith r
r a
a

-- | Run the decoder for a supporting type using the given environment.
binDecodeWith :: BinaryCodecWith r a => r -> BS.ByteString -> Either String a
binDecodeWith :: forall r a.
BinaryCodecWith r a =>
r -> ByteString -> Either String a
binDecodeWith = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet (Get a -> ByteString -> Either String a)
-> (r -> Get a) -> r -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Get a
forall r a. BinaryCodecWith r a => r -> Get a
fromBinWith