{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Binary.FixedSizeCodec (
  FixedSizeCodec (..),
  decodeFixedSized,
  encodeFixedSized,
  fixedSize,
  guardFixedSized,
) where

import Cardano.Binary (Decoder, Encoding, decodeBytes, encodeBytes)
import Control.Monad (when)
import qualified Data.ByteString as BS
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable, typeRep)
import GHC.TypeLits (KnownNat, Nat, natVal)

class KnownNat (FixedSize a) => FixedSizeCodec a where
  type FixedSize a :: Nat
  rawEncodeFixedSized :: a -> BS.ByteString
  rawDecodeFixedSized :: MonadFail m => BS.ByteString -> m a

fixedSize :: forall a proxy. FixedSizeCodec a => proxy a -> Word
fixedSize :: forall a (proxy :: * -> *). FixedSizeCodec a => proxy a -> Word
fixedSize proxy a
_ = forall a. Num a => Integer -> a
fromInteger @Word (Integer -> Word)
-> (Proxy (FixedSize a) -> Integer) -> Proxy (FixedSize a) -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (FixedSize a) -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (FixedSize a) -> Word) -> Proxy (FixedSize a) -> Word
forall a b. (a -> b) -> a -> b
$ forall (t :: Nat). Proxy t
forall {k} (t :: k). Proxy t
Proxy @(FixedSize a)

guardFixedSized ::
  forall a m.
  (FixedSizeCodec a, MonadFail m, Typeable a) =>
  BS.ByteString -> m a -> m a
guardFixedSized :: forall a (m :: * -> *).
(FixedSizeCodec a, MonadFail m, Typeable a) =>
ByteString -> m a -> m a
guardFixedSized ByteString
bs m a
action = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
actualSize Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
/= Word
expectedSize) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      ( String
tyName
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": wrong length, expected "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
expectedSize
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" bytes but got "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
actualSize
      )
  m a
action
  where
    tyName :: String
tyName = TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> TypeRep) -> Proxy a -> TypeRep
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
    expectedSize :: Word
expectedSize = Proxy a -> Word
forall a (proxy :: * -> *). FixedSizeCodec a => proxy a -> Word
fixedSize (Proxy a -> Word) -> Proxy a -> Word
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a
    actualSize :: Word
actualSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
bs
{-# INLINE guardFixedSized #-}

decodeFixedSized :: FixedSizeCodec a => Decoder s a
decodeFixedSized :: forall a s. FixedSizeCodec a => Decoder s a
decodeFixedSized = Decoder s ByteString
forall s. Decoder s ByteString
decodeBytes Decoder s ByteString -> (ByteString -> Decoder s a) -> Decoder s a
forall a b. Decoder s a -> (a -> Decoder s b) -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Decoder s a
forall a (m :: * -> *).
(FixedSizeCodec a, MonadFail m) =>
ByteString -> m a
forall (m :: * -> *). MonadFail m => ByteString -> m a
rawDecodeFixedSized

encodeFixedSized :: FixedSizeCodec a => a -> Encoding
encodeFixedSized :: forall a. FixedSizeCodec a => a -> Encoding
encodeFixedSized = ByteString -> Encoding
encodeBytes (ByteString -> Encoding) -> (a -> ByteString) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. FixedSizeCodec a => a -> ByteString
rawEncodeFixedSized