-- | Copied from plutus-ledger-api because not exported
module Codec.CBOR.Extras where

import Codec.CBOR.Decoding as CBOR
import Codec.Serialise (Serialise, decode, encode)
import Flat qualified
import Flat.Decoder qualified as Flat

-- | Newtype to provide 'Serialise' instances for types with a 'Flat' instance that
-- just encodes the flat-serialized value as a CBOR bytestring
newtype SerialiseViaFlat a = SerialiseViaFlat a
instance Flat.Flat a => Serialise (SerialiseViaFlat a) where
  encode :: SerialiseViaFlat a -> Encoding
encode (SerialiseViaFlat a
a) = ByteString -> Encoding
forall a. Serialise a => a -> Encoding
encode (ByteString -> Encoding) -> ByteString -> Encoding
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. Flat a => a -> ByteString
Flat.flat a
a
  decode :: Decoder s (SerialiseViaFlat a)
decode = a -> SerialiseViaFlat a
forall a. a -> SerialiseViaFlat a
SerialiseViaFlat (a -> SerialiseViaFlat a)
-> Decoder s a -> Decoder s (SerialiseViaFlat a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get a -> Decoder s a
forall a s. Get a -> Decoder s a
decodeViaFlat (Get a
forall a. Flat a => Get a
Flat.decode))

decodeViaFlat :: Flat.Get a -> CBOR.Decoder s a
decodeViaFlat :: Get a -> Decoder s a
decodeViaFlat Get a
decoder = do
    ByteString
bs <- Decoder s ByteString
forall s. Decoder s ByteString
decodeBytes
    case Get a -> ByteString -> Decoded a
forall b a. AsByteString b => Get a -> b -> Decoded a
Flat.unflatWith Get a
decoder ByteString
bs of
        Left  DecodeException
err -> String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (DecodeException -> String
forall a. Show a => a -> String
show DecodeException
err)
        Right a
v   -> a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v