{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Utilities for writing binary data.
module H2JVM.Internal.Binary.Write (WriteBinary (..), writeList) where

import Data.Binary
import Data.Vector (Vector)
import GHC.Stack
import Witch

-- | Like 'Data.Binary.Binary' but only supporting writing
class WriteBinary a where
    writeBinary :: a -> Put

instance {-# OVERLAPPABLE #-} Binary a => WriteBinary a where
    writeBinary :: a -> Put
writeBinary = a -> Put
forall a. Binary a => a -> Put
put

{- | Write a list of items, prefixed by its length.
If the length of the list cannot be safely converted to the type of length prefix, this will throw an error.
-}
writeList ::
    (WriteBinary a, Integral i, Foldable t, HasCallStack, TryFrom Int i) =>
    -- | function to write the length of the list
    (i -> Put) ->
    t a ->
    Put
writeList :: forall a i (t :: * -> *).
(WriteBinary a, Integral i, Foldable t, HasCallStack,
 TryFrom Int i) =>
(i -> Put) -> t a -> Put
writeList i -> Put
putLength t a
xs =
    let len' :: Either (TryFromException Int i) i
len' = Int -> Either (TryFromException Int i) i
forall target source.
TryFrom source target =>
source -> Either (TryFromException source target) target
tryInto (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs)
     in case Either (TryFromException Int i) i
len' of
            Left TryFromException Int i
_ -> [Char] -> Put
forall a. HasCallStack => [Char] -> a
error ([Char] -> Put) -> [Char] -> Put
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot write list of length " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
xs) [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" as it cannot be safely converted to the length prefix type."
            Right i
len -> i -> Put
putLength i
len Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> Put) -> t a -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall a. WriteBinary a => a -> Put
writeBinary t a
xs
{-# SPECIALIZE writeList :: WriteBinary a => (Word16 -> Put) -> Vector a -> Put #-}
{-# SPECIALIZE writeList :: WriteBinary a => (Word16 -> Put) -> [a] -> Put #-}