{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | MemoBytes is an abstration for a datetype that encodes its own seriialization.
--   The idea is to use a newtype around a MemoBytes non-memoizing version.
--   For example:   newtype Foo = Foo(MemoBytes NonMemoizingFoo)
--   This way all the instances for Foo (Eq,Show,Ord,ToCBOR,FromCBOR,NoThunks,Generic)
--   can be derived for free.
module Data.Coders
  ( Encode (..),
    Decode (..),
    (!>),
    (<!),
    Wrapped (..),
    encode,
    decode,
    runE,            -- Used in testing
    decodeClosed,    -- Used in testing
    decodeList,
    decodeSeq,
    decodeStrictSeq,
    decodeSet,
    encodeList,
    encodeSeq,
    encodeStrictSeq,
    encodeSet,
    decodeRecordNamed,
    decodeRecordSum,
    invalidKey,
    wrapCBORArray,
    encodeFoldable,
    decodeCollectionWithLen,
    decodeCollection,
    encodeFoldableEncoder,
    roundTrip,
  )
where

import Cardano.Prelude (cborError)
import Control.Monad (replicateM,unless)
import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding)
import Codec.CBOR.Read(DeserialiseFailure,deserialiseFromBytes)
import Codec.CBOR.Write (toLazyByteString)
import qualified Data.ByteString.Lazy as Lazy
import Cardano.Binary
  ( FromCBOR (fromCBOR),
    ToCBOR (toCBOR),
    encodeListLen,
    encodeWord,
    encodeBreak,
    encodeListLenIndef,
    DecoderError( DecoderErrorCustom ),
    decodeBreakOr,
    decodeListLenOrIndef,
    decodeWord,
    matchSize,
  )
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Sequence.Strict (StrictSeq)
import Data.Sequence (Seq)
import Data.Set (Set)
import Data.Text (Text)
import Data.Foldable (foldl')
import Prelude hiding (span)

decodeRecordNamed :: Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed :: Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
name a -> Int
getRecordSize Decoder s a
decoder = do
  Maybe Int
lenOrIndef <- Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef
  a
x <- Decoder s a
decoder
  case Maybe Int
lenOrIndef of
    Just Int
n -> Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize (String -> Text
Text.pack String
"\nRecord " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name) Int
n (a -> Int
getRecordSize a
x)
    Maybe Int
Nothing -> do
      Bool
isBreak <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isBreak (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
name Text
"Excess terms in array"
  a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

decodeRecordSum :: String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum :: String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum String
name Word -> Decoder s (Int, a)
decoder = do
  Maybe Int
lenOrIndef <- Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef
  Word
tag <- Decoder s Word
forall s. Decoder s Word
decodeWord
  (Int
size, a
x) <- Word -> Decoder s (Int, a)
decoder Word
tag -- we decode all the stuff we want
  case Maybe Int
lenOrIndef of
    Just Int
n -> Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize (String -> Text
Text.pack (String
"\nSum " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nreturned=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" actually read= " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)) Int
size Int
n
    Maybe Int
Nothing -> do
      Bool
isBreak <- Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr -- if there is stuff left, it is unnecessary extra stuff
      Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isBreak (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ DecoderError -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s ()) -> DecoderError -> Decoder s ()
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom (String -> Text
Text.pack String
name) Text
"Excess terms in array"
  a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

invalidKey :: Word -> Decoder s a
invalidKey :: Word -> Decoder s a
invalidKey Word
k = DecoderError -> Decoder s a
forall e s a. Buildable e => e -> Decoder s a
cborError (DecoderError -> Decoder s a) -> DecoderError -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"not a valid key:" (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word -> String
forall a. Show a => a -> String
show Word
k)

decodeList :: Decoder s a -> Decoder s [a]
decodeList :: Decoder s a -> Decoder s [a]
decodeList = Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
forall s a. Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef

decodeSeq :: Decoder s a -> Decoder s (Seq a)
decodeSeq :: Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s a
decoder = [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList ([a] -> Seq a) -> Decoder s [a] -> Decoder s (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
decoder

decodeStrictSeq :: Decoder s a -> Decoder s (StrictSeq a)
decodeStrictSeq :: Decoder s a -> Decoder s (StrictSeq a)
decodeStrictSeq Decoder s a
decoder = [a] -> StrictSeq a
forall a. [a] -> StrictSeq a
StrictSeq.fromList ([a] -> StrictSeq a) -> Decoder s [a] -> Decoder s (StrictSeq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
decoder

decodeSet :: Ord a => Decoder s a -> Decoder s (Set a)
decodeSet :: Decoder s a -> Decoder s (Set a)
decodeSet Decoder s a
decoder = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> Decoder s [a] -> Decoder s (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
decoder

decodeCollection :: Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection :: Decoder s (Maybe Int) -> Decoder s a -> Decoder s [a]
decodeCollection Decoder s (Maybe Int)
lenOrIndef Decoder s a
el = (Int, [a]) -> [a]
forall a b. (a, b) -> b
snd ((Int, [a]) -> [a]) -> Decoder s (Int, [a]) -> Decoder s [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
forall s a.
Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
decodeCollectionWithLen Decoder s (Maybe Int)
lenOrIndef Decoder s a
el

decodeCollectionWithLen ::
  Decoder s (Maybe Int) ->
  Decoder s a ->
  Decoder s (Int, [a])
decodeCollectionWithLen :: Decoder s (Maybe Int) -> Decoder s a -> Decoder s (Int, [a])
decodeCollectionWithLen Decoder s (Maybe Int)
lenOrIndef Decoder s a
el = do
  Decoder s (Maybe Int)
lenOrIndef Decoder s (Maybe Int)
-> (Maybe Int -> Decoder s (Int, [a])) -> Decoder s (Int, [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just Int
len -> (,) Int
len ([a] -> (Int, [a])) -> Decoder s [a] -> Decoder s (Int, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Decoder s a -> Decoder s [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
len Decoder s a
el
    Maybe Int
Nothing -> (Int, [a]) -> Decoder s Bool -> Decoder s a -> Decoder s (Int, [a])
forall (m :: * -> *) a a.
(Monad m, Num a) =>
(a, [a]) -> m Bool -> m a -> m (a, [a])
loop (Int
0, []) (Bool -> Bool
not (Bool -> Bool) -> Decoder s Bool -> Decoder s Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr) Decoder s a
el
  where
    loop :: (a, [a]) -> m Bool -> m a -> m (a, [a])
loop (a
n, [a]
acc) m Bool
condition m a
action =
      m Bool
condition m Bool -> (Bool -> m (a, [a])) -> m (a, [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
False -> (a, [a]) -> m (a, [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
n, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)
        Bool
True -> m a
action m a -> (a -> m (a, [a])) -> m (a, [a])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
v -> (a, [a]) -> m Bool -> m a -> m (a, [a])
loop (a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, (a
v a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)) m Bool
condition m a
action

encodeFoldable :: (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable :: f a -> Encoding
encodeFoldable = (a -> Encoding) -> f a -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

encodeFoldableEncoder :: (Foldable f) => (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder :: (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder a -> Encoding
encoder f a
xs = Word -> Encoding -> Encoding
wrapCBORArray Word
len Encoding
contents
  where
    (Word
len, Encoding
contents) = ((Word, Encoding) -> a -> (Word, Encoding))
-> (Word, Encoding) -> f a -> (Word, Encoding)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word, Encoding) -> a -> (Word, Encoding)
go (Word
0, Encoding
forall a. Monoid a => a
mempty) f a
xs
    go :: (Word, Encoding) -> a -> (Word, Encoding)
go (!Word
l, !Encoding
enc) a
next = (Word
l Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encoder a
next)

wrapCBORArray :: Word -> Encoding -> Encoding
wrapCBORArray :: Word -> Encoding -> Encoding
wrapCBORArray Word
len Encoding
contents =
  if Word
len Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
23
    then Word -> Encoding
encodeListLen Word
len Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents
    else Encoding
encodeListLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak


-- ===============================================================================
-- Encode and Decode are typed data structures which specify encoders and decoders.
-- The types keep one from making mistakes, and count the correct number fields
-- in an encoding and decoding. They are somewhat dual, and are designed that visual
-- inspection of a Encode and its dual Decode can help the user conclude that the
-- two are self-consistent. They are also reusable abstractions that can be defined
-- once, and then used many places.
--
-- (Encode t) is a data structure from which 3 things can be recovered
-- Given:    x :: Encode t
-- 1) get a value of type t
-- 2) get an Encoding for that value, which correctly encodes the number of "fields"
--    written to the ByteString. Care must still be taken that the tags are correct.
-- 3) get a (MemoBytes t)
-- The advantage of using Encode with a MemoBytes, is we don't have to make a ToCBOR
-- instance. Instead the "instance" is spread amongst the pattern constuctors by using
-- (memoBytes encoding) in the where clause of the pattern contructor.
-- See some examples of this see the file Timelocks.hs
--
-- The Encode and Decode mechanism can also be used to encode Algebraic datatypes
-- in a uniform way. (Decode t) is dual to (Encode t). A decoder can be extracted
-- from it. And it will consistently decode it's dual. We now give some examples.
-- In the examples Let  Int and C have ToCBOR instances, and
-- encodeB :: B -> Encoding, and decodeB :: Decoder s B
{-
-- An example with 1 constructor (a record) uses Rec and RecD

data A = ACon Int B C

encodeA :: A -> Encode 'Closed A
encodeA (ACon i b c) = Rec ACon !> To i !> E encodeB b !> To c

decodeA :: Decode 'Closed A
decodeA = RecD ACon <! From <! D decodeB <! From

instance ToCBOR A   where toCBOR x = encode(encodeA x)
instance FromCBOR A where fromCBOR = decode decodeA

-- An example with multiple constructors uses Sum, SumD, and Summands

data M = M1 Int | M2 B Bool | M3 A

encodeM :: M -> Encode 'Open M
encodeM (M1 i)    = Sum M1 0 !> To i
encodeM (M2 b tf) = Sum M2 1 !> E encodeB b  !> To tf
encodeM (M3 a)    = Sum M3 2 !> To a

decodeM :: Decode 'Closed M
decodeM = Summands "M" decodeMx
  where decodeMx 0 = SumD M1 <! From
        decodeMx 1 = SumD M2 <! D decodeB <! From
        decodeMx 3 = SumD M3 <! From
        decodeMx k = Invalid k

instance ToCBOR M   where toCBOR x = encode(encodeM x)
instance FromCBOR M where fromCBOR = decode decodeM
-}
-- For more examples writing CBOR instances using Encode and Decode see the test file
-- shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/MemoBytes.hs

-- ========================================================

-- | Some CBOR instances wrap encoding sequences with prefixes and suffixes. I.e.
--  prefix , encode, encode, encode , ... , suffix
--  A type that MUST do this is called 'Open. Other types are called 'Closed.
--  The point is that a Closed type may have a prefix, but it can still be 'inlined'
--  by using the context it appears in, inside another Closed type. It does so by
--  sharing the prefix of its containing type, and using positional context.
--  In terms of Open and Closed, a datatype with more than one constructor is Open,
--  and one with only one constructor is Closed (we call these records). Primitive
--  types with no constructors can also be inlined, so we mark them as closed.
data Wrapped = Open | Closed

-- ===========================================================

data Encode (w :: Wrapped) t where
  Sum :: t -> Word -> Encode 'Open t
  Rec :: t -> Encode 'Closed t
  To :: ToCBOR a => a -> Encode 'Closed a
  E :: (t -> Encoding) -> t -> Encode 'Closed t
  ApplyE :: Encode w (a -> t) -> Encode 'Closed a -> Encode w t

-- The Wrapped index of ApplyE is determined by the index
-- at the bottom of its left spine. The LEFT arg of ApplyE
-- must be a function type, and the only Encode with function
-- types are (Sum c tag) and (Rec c). So if the leftmost spine
-- is (Sum c tag) it is 'Open, and if is (Rec c) it is 'Closed.
-- The RIGHT arg of ApplyE must be 'Closed. This allows us to
-- inline anything in a RIGHT arg, supporting CBORGroup capability.

infixl 4 !>

(!>) :: Encode w (a -> t) -> Encode 'Closed a -> Encode w t
Encode w (a -> t)
x !> :: Encode w (a -> t) -> Encode 'Closed a -> Encode w t
!> Encode 'Closed a
y = Encode w (a -> t) -> Encode 'Closed a -> Encode w t
forall (w :: Wrapped) a t.
Encode w (a -> t) -> Encode 'Closed a -> Encode w t
ApplyE Encode w (a -> t)
x Encode 'Closed a
y

runE :: Encode w t -> t
runE :: Encode w t -> t
runE (Sum t
c Word
_) = t
c
runE (Rec t
c) = t
c
runE (ApplyE Encode w (a -> t)
f Encode 'Closed a
x) = Encode w (a -> t) -> a -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode w (a -> t)
f (Encode 'Closed a -> a
forall (w :: Wrapped) t. Encode w t -> t
runE Encode 'Closed a
x)
runE (To t
x) = t
x
runE (E t -> Encoding
_ t
x) = t
x

gsize :: Encode w t -> Word
gsize :: Encode w t -> Word
gsize (Sum t
_ Word
_) = Word
0
gsize (Rec t
_) = Word
0
gsize (To t
_) = Word
1
gsize (E t -> Encoding
_ t
_) = Word
1
gsize (ApplyE Encode w (a -> t)
f Encode 'Closed a
x) = Encode w (a -> t) -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode w (a -> t)
f Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Encode 'Closed a -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode 'Closed a
x

encode :: Encode w t -> Encoding
encode :: Encode w t -> Encoding
encode Encode w t
sym = Word -> Encode w t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
0 Encode w t
sym
  where
    encodeCountPrefix :: Word -> Encode w t -> Encoding
    encodeCountPrefix :: Word -> Encode w t -> Encoding
encodeCountPrefix Word
n (Sum t
_ Word
tag) = Word -> Encoding
encodeListLen (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
encodeWord Word
tag
    encodeCountPrefix Word
n (Rec t
_) = Word -> Encoding
encodeListLen Word
n
    -- n is the number of fields we must write in the prefx.
    encodeCountPrefix Word
_ (To t
x) = t -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR t
x
    encodeCountPrefix Word
_ (E t -> Encoding
enc t
x) = t -> Encoding
enc t
x
    encodeCountPrefix Word
n (ApplyE Encode w (a -> t)
f Encode 'Closed a
x) =
      Word -> Encode w (a -> t) -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix (Word
n Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Encode 'Closed a -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode 'Closed a
x) Encode w (a -> t)
f Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode 'Closed a -> Encoding
forall t. Encode 'Closed t -> Encoding
encodeClosed Encode 'Closed a
x
    -- The RIGHT arg may be any 'Closed Encode, and is inlined
    -- by design. Its left spine must end in a (Rec c). We count (gsize x)
    -- the 'fields' in x, and add them to the number things we
    -- must add to the prefix of the enclosing type.

    encodeClosed :: Encode 'Closed t -> Encoding
    -- encodeClosed (Sum _ _) -- By design this case is unreachable by type considerations.
    encodeClosed :: Encode 'Closed t -> Encoding
encodeClosed (Rec t
_) = Encoding
forall a. Monoid a => a
mempty
    encodeClosed (To t
x) = t -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR t
x
    encodeClosed (E t -> Encoding
enc t
x) = t -> Encoding
enc t
x
    encodeClosed (ApplyE Encode 'Closed (a -> t)
f Encode 'Closed a
x) = Encode 'Closed (a -> t) -> Encoding
forall t. Encode 'Closed t -> Encoding
encodeClosed Encode 'Closed (a -> t)
f Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode 'Closed a -> Encoding
forall t. Encode 'Closed t -> Encoding
encodeClosed Encode 'Closed a
x

-- =====================
data Decode (w :: Wrapped) t where
  Summands :: String -> (Word -> Decode 'Open t) -> Decode 'Closed t
  SumD :: t -> Decode 'Open t
  RecD :: t -> Decode 'Closed t
  From :: FromCBOR t => Decode 'Closed t
  D :: (forall s. Decoder s t) -> Decode 'Closed t
  ApplyD :: Decode w (a -> t) -> Decode 'Closed a -> Decode w t
  Invalid :: Word -> Decode w t
  Map :: (a -> b) -> Decode w a -> Decode w b

infixl 4 <!

(<!) :: Decode w (a -> t) -> Decode 'Closed a -> Decode w t
Decode w (a -> t)
x <! :: Decode w (a -> t) -> Decode 'Closed a -> Decode w t
<! Decode 'Closed a
y = Decode w (a -> t) -> Decode 'Closed a -> Decode w t
forall (w :: Wrapped) a t.
Decode w (a -> t) -> Decode 'Closed a -> Decode w t
ApplyD Decode w (a -> t)
x Decode 'Closed a
y

hsize :: Decode w t -> Int
hsize :: Decode w t -> Int
hsize (Summands String
_ Word -> Decode 'Open t
_) = Int
1
hsize (SumD t
_) = Int
0
hsize (RecD t
_) = Int
0
hsize Decode w t
From = Int
1
hsize (D forall s. Decoder s t
_) = Int
1
hsize (ApplyD Decode w (a -> t)
f Decode 'Closed a
x) = Decode w (a -> t) -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (a -> t)
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode 'Closed a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode 'Closed a
x
hsize (Invalid Word
_) = Int
0
hsize (Map a -> t
_ Decode w a
x) = Decode w a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w a
x

decode :: Decode w t -> Decoder s t
decode :: Decode w t -> Decoder s t
decode Decode w t
x = ((Int, t) -> t) -> Decoder s (Int, t) -> Decoder s t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, t) -> t
forall a b. (a, b) -> b
snd (Decode w t -> Decoder s (Int, t)
forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE Decode w t
x)

decodE :: Decode w t -> Decoder s (Int, t)
decodE :: Decode w t -> Decoder s (Int, t)
decodE Decode w t
x = Decode w t -> Int -> Decoder s (Int, t)
forall (w :: Wrapped) t s. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
0

decodeCount :: Decode w t -> Int -> Decoder s (Int, t)
decodeCount :: Decode w t -> Int -> Decoder s (Int, t)
decodeCount (Summands String
nm Word -> Decode 'Open t
f) Int
n = (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,) (t -> (Int, t)) -> Decoder s t -> Decoder s (Int, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Word -> Decoder s (Int, t)) -> Decoder s t
forall s a. String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum String
nm (\Word
x -> Decode 'Open t -> Decoder s (Int, t)
forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE (Word -> Decode 'Open t
f Word
x))
decodeCount (SumD t
c) Int
n = (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, t
c)
decodeCount (RecD t
c) Int
n = Text
-> ((Int, t) -> Int) -> Decoder s (Int, t) -> Decoder s (Int, t)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"RecD" (Int -> (Int, t) -> Int
forall a b. a -> b -> a
const Int
n) ((Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
c))
decodeCount Decode w t
From Int
n = do t
x <- Decoder s t
forall a s. FromCBOR a => Decoder s a
fromCBOR; (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
x)
decodeCount (D forall s. Decoder s t
dec) Int
n = do t
x <- Decoder s t
forall s. Decoder s t
dec; (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
x)
decodeCount (ApplyD Decode w (a -> t)
c Decode 'Closed a
g) Int
n = do
  (Int
i, a -> t
f) <- Decode w (a -> t) -> Int -> Decoder s (Int, a -> t)
forall (w :: Wrapped) t s. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (a -> t)
c (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode 'Closed a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode 'Closed a
g)
  a
y <- Decode 'Closed a -> Decoder s a
forall t s. Decode 'Closed t -> Decoder s t
decodeClosed Decode 'Closed a
g
  (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, a -> t
f a
y)
decodeCount (Invalid Word
k) Int
_ = Word -> Decoder s (Int, t)
forall s a. Word -> Decoder s a
invalidKey Word
k
decodeCount (Map a -> t
f Decode w a
x) Int
n = do (Int
m, a
y) <- Decode w a -> Int -> Decoder s (Int, a)
forall (w :: Wrapped) t s. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w a
x Int
n; (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, a -> t
f a
y)

decodeClosed :: Decode 'Closed t -> Decoder s t
decodeClosed :: Decode 'Closed t -> Decoder s t
decodeClosed (Summands String
nm Word -> Decode 'Open t
f) = String -> (Word -> Decoder s (Int, t)) -> Decoder s t
forall s a. String -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum String
nm (\Word
x -> Decode 'Open t -> Decoder s (Int, t)
forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE (Word -> Decode 'Open t
f Word
x))
-- decodeClosed (SumD _) = undefined -- This case, by design, is unreachable by type considerations
decodeClosed (RecD t
c) = t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
c
decodeClosed Decode 'Closed t
From = do t
x <- Decoder s t
forall a s. FromCBOR a => Decoder s a
fromCBOR; t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
decodeClosed (D forall s. Decoder s t
dec) = do t
x <- Decoder s t
forall s. Decoder s t
dec; t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
decodeClosed (ApplyD Decode 'Closed (a -> t)
c Decode 'Closed a
g) = do
  a -> t
f <- Decode 'Closed (a -> t) -> Decoder s (a -> t)
forall t s. Decode 'Closed t -> Decoder s t
decodeClosed Decode 'Closed (a -> t)
c
  a
y <- Decode 'Closed a -> Decoder s a
forall t s. Decode 'Closed t -> Decoder s t
decodeClosed Decode 'Closed a
g
  t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> t
f a
y)
decodeClosed (Invalid Word
k) = Word -> Decoder s t
forall s a. Word -> Decoder s a
invalidKey Word
k
decodeClosed (Map a -> t
f Decode 'Closed a
x) = a -> t
f (a -> t) -> Decoder s a -> Decoder s t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode 'Closed a -> Decoder s a
forall t s. Decode 'Closed t -> Decoder s t
decodeClosed Decode 'Closed a
x

instance Functor (Decode w) where
  fmap :: (a -> b) -> Decode w a -> Decode w b
fmap a -> b
f (Map a -> a
g Decode w a
x) = (a -> b) -> Decode w a -> Decode w b
forall a b (w :: Wrapped). (a -> b) -> Decode w a -> Decode w b
Map (a -> b
f (a -> b) -> (a -> a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
g) Decode w a
x
  fmap a -> b
f Decode w a
x = (a -> b) -> Decode w a -> Decode w b
forall a b (w :: Wrapped). (a -> b) -> Decode w a -> Decode w b
Map a -> b
f Decode w a
x

-- ===========================================================================================
-- These functions are the dual analogs to
-- Shelley.Spec.Ledger.Serialization(decodeList, decodeSeq, decodeStrictSeq, decodeSet)
-- It is not well documented how to use encodeFoldable.
-- They are provided here as compatible pairs for use with the (E x) and (D x) constructors
-- of the Encode and Decode types. (E encodeList xs) and (D (decodeList fromCBOR)) should be duals.

encodeList :: ToCBOR a => [a] -> Encoding
encodeList :: [a] -> Encoding
encodeList = [a] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

encodeStrictSeq :: ToCBOR a => StrictSeq a -> Encoding
encodeStrictSeq :: StrictSeq a -> Encoding
encodeStrictSeq = StrictSeq a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

encodeSeq :: ToCBOR a => Seq a -> Encoding
encodeSeq :: Seq a -> Encoding
encodeSeq = Seq a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

encodeSet :: ToCBOR a => Set a -> Encoding
encodeSet :: Set a -> Encoding
encodeSet = Set a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

-- ===========================================
-- For a worked out EXAMPLE see the testfile:
-- cardano-ledger-specs/shelley/chain-and-ledger/shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/MemoBytes.hs

roundTrip :: (ToCBOR t,FromCBOR t) => t -> Either Codec.CBOR.Read.DeserialiseFailure (Lazy.ByteString, t)
roundTrip :: t -> Either DeserialiseFailure (ByteString, t)
roundTrip t
s = (forall s. Decoder s t)
-> ByteString -> Either DeserialiseFailure (ByteString, t)
forall a.
(forall s. Decoder s a)
-> ByteString -> Either DeserialiseFailure (ByteString, a)
deserialiseFromBytes forall s. Decoder s t
forall a s. FromCBOR a => Decoder s a
fromCBOR (Encoding -> ByteString
toLazyByteString (t -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR t
s))