{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Cardano.Ledger.Binary.Decoding.Coders (
  -- * Creating decoders.

  --
  -- $Decoders
  Decode (..),
  (<!),
  (<*!),
  (<?),
  decode,
  decodeSparse,
  mapCoder,

  -- * Index types for well-formed Coders.

  --
  -- $Indexes
  Density (..),
  Wrapped (..),
  Field (..),
  ofield,
  invalidField,
  field,
  fieldGuarded,
  fieldA,
  fieldAA,

  -- * Using Duals
  decodeDual,

  -- * Containers, Combinators

  --
  -- $Combinators
  listDecodeA,
  mapDecodeA,
  setDecodeA,

  -- * Low level (Encoding/Decoder) utility functions
  decodeRecordNamed,
  decodeRecordNamedT,
  decodeRecordSum,
  invalidKey,
  unusedRequiredKeys,
  duplicateKey,
  guardUntilAtLeast,
) where

import Cardano.Ledger.Binary.Decoding.Annotated (Annotator (..), decodeAnnSet)
import Cardano.Ledger.Binary.Decoding.DecCBOR (DecCBOR (decCBOR))
import Cardano.Ledger.Binary.Decoding.Decoder
import Cardano.Ledger.Binary.Encoding.EncCBOR (EncCBOR (encCBOR))
import Cardano.Ledger.Binary.Group (DecCBORGroup (..), EncCBORGroup (..))
import Cardano.Ledger.Binary.Version (Version)
#if ! MIN_VERSION_base(4,18,0)
import Control.Applicative (liftA2)
#endif
import Control.Monad (when)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Set (Set, insert, member)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Typeable (Proxy (..), Typeable, typeOf)
import Data.Void (Void)

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

-- ===============================================================================
-- Encode and Decode are typed data structures which specify encoders and decoders
-- for Algebraic data structures written in Haskell. They exploit types and count
-- the correct number fields in an encoding and decoding, which are automatically computed.
-- They are somewhat dual, and are designed so 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 Keys are correct.
-- 3. get a (MemoBytes t)
--
-- The advantage of using Encode with a MemoBytes, is we don't have to make a EncCBOR
-- 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
--

-- ========================================================
-- Subsidary classes and datatype used in the Coders scheme
-- =========================================================

-- $Indexes
--  Some CBOR instances wrap encoding sequences with prefixes and suffixes. I.e.
--  prefix , encode, encode, encode , ... , suffix.
--  There are two kinds of wrapping coders: Nary sums, and Sparsely encoded products.
--  Coders in these classes can only be decoded when they are wrapped by their
--  closing forms 'Summands' and 'SparseKeyed'. Another dimension, where we use indexes
--  to maintain type safety, are records which can be
--  encoded densely (all their fields serialised) or sparsely (only some of their
--  fields). We use indexes to types to try and mark (and enforce) these distinctions.

-- | Index for record density. Distinguishing (all the fields) from (some of the fields).
data Density = Dense | Sparse

-- | Index for a wrapped Coder. Wrapping is necessary for 'Summands' and 'SparseKeyed'.
data Wrapped where
  Open :: Wrapped -- Needs some type-wide wrapping
  Closed :: Density -> Wrapped -- Does not need type-wide wrapping,
  -- But may need field-wide wrapping, when Density is 'Sparse

-- | A Field pairs an update function and a decoder for one field of a Sparse record.
data Field t where
  Field :: (x -> t -> t) -> (forall s. Decoder s x) -> Field t

{-# INLINE field #-}
field :: Typeable x => (x -> t -> t) -> Decode ('Closed d) x -> Field t
field :: forall x t (d :: Density).
Typeable x =>
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field x -> t -> t
update Decode ('Closed d) x
dec = (x -> t -> t) -> (forall s. Decoder s x) -> Field t
forall x t. (x -> t -> t) -> (forall s. Decoder s x) -> Field t
Field x -> t -> t
update (Decode ('Closed d) x -> Decoder s x
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)

{-# INLINE fieldGuarded #-}
fieldGuarded ::
  Typeable x =>
  -- | The message to use if the condition fails
  String ->
  -- | The condition to guard against
  (x -> Bool) ->
  (x -> t -> t) ->
  Decode ('Closed d) x ->
  Field t
fieldGuarded :: forall x t (d :: Density).
Typeable x =>
String
-> (x -> Bool) -> (x -> t -> t) -> Decode ('Closed d) x -> Field t
fieldGuarded String
failMsg x -> Bool
check x -> t -> t
update Decode ('Closed d) x
dec =
  (x -> t -> t) -> (forall s. Decoder s x) -> Field t
forall x t. (x -> t -> t) -> (forall s. Decoder s x) -> Field t
Field
    x -> t -> t
update
    ( Decode ('Closed d) x -> Decoder s x
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec Decoder s x -> (x -> Decoder s x) -> Decoder s x
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
>>= \x
x ->
        x
x x -> Decoder s () -> Decoder s x
forall a b. a -> Decoder s b -> Decoder s a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (x -> Bool
check x
x) (String -> Decoder s ()
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failMsg)
    )

{-# INLINE ofield #-}
ofield :: Typeable x => (StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
ofield :: forall x t (d :: Density).
Typeable x =>
(StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
ofield StrictMaybe x -> t -> t
update Decode ('Closed d) x
dec = (StrictMaybe x -> t -> t)
-> (forall s. Decoder s (StrictMaybe x)) -> Field t
forall x t. (x -> t -> t) -> (forall s. Decoder s x) -> Field t
Field StrictMaybe x -> t -> t
update (x -> StrictMaybe x
forall a. a -> StrictMaybe a
SJust (x -> StrictMaybe x) -> Decoder s x -> Decoder s (StrictMaybe x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode ('Closed d) x -> Decoder s x
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)

{-# INLINE invalidField #-}
invalidField :: forall t. Word -> Field t
invalidField :: forall t. Word -> Field t
invalidField Word
n = (Void -> t -> t) -> Decode ('Closed Any) Void -> Field t
forall x t (d :: Density).
Typeable x =>
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field ((t -> Void -> t) -> Void -> t -> t
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((t -> Void -> t) -> Void -> t -> t)
-> (t -> Void -> t) -> Void -> t -> t
forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const @t @Void) (Word -> Decode ('Closed Any) Void
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n)

-- | Sparse decode something with a (DecCBOR (Annotator t)) instance
-- A special case of 'field'
fieldA :: (Typeable x, Applicative ann) => (x -> t -> t) -> Decode ('Closed d) x -> Field (ann t)
fieldA :: forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) x -> Field (ann t)
fieldA x -> t -> t
update Decode ('Closed d) x
dec = (ann x -> ann t -> ann t)
-> (forall s. Decoder s (ann x)) -> Field (ann t)
forall x t. (x -> t -> t) -> (forall s. Decoder s x) -> Field t
Field ((x -> t -> t) -> ann x -> ann t -> ann t
forall a b c. (a -> b -> c) -> ann a -> ann b -> ann c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> t -> t
update) (x -> ann x
forall a. a -> ann a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> ann x) -> Decoder s x -> Decoder s (ann x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode ('Closed d) x -> Decoder s x
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)
{-# INLINE fieldA #-}

-- | Sparse decode something with a (DecCBOR (Annotator t)) instance
fieldAA ::
  (Typeable x, Typeable ann, Applicative ann) =>
  (x -> t -> t) ->
  Decode ('Closed d) (ann x) ->
  Field (ann t)
fieldAA :: forall x (ann :: * -> *) t (d :: Density).
(Typeable x, Typeable ann, Applicative ann) =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA x -> t -> t
update Decode ('Closed d) (ann x)
dec = (ann x -> ann t -> ann t)
-> (forall s. Decoder s (ann x)) -> Field (ann t)
forall x t. (x -> t -> t) -> (forall s. Decoder s x) -> Field t
Field ((x -> t -> t) -> ann x -> ann t -> ann t
forall a b c. (a -> b -> c) -> ann a -> ann b -> ann c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> t -> t
update) (Decode ('Closed d) (ann x) -> Decoder s (ann x)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed d) (ann x)
dec)
{-# INLINE fieldAA #-}

-- ==================================================================
-- Decode
-- ===================================================================

-- | The type @('Decode' t)@ is designed to be dual to @('Encode' t)@. It was designed so that
-- in many cases a decoder can be extracted from an encoder by visual inspection. We now give some
-- example of @(Decode t)@  and  @(Encode t)@ pairs.
--
--
-- An example with 1 constructor (a record) uses 'Rec' and 'RecD'
--
-- In this example, let @Int@ and @C@ have 'EncCBOR' instances.
--
-- @
-- data C = C { unC :: Text.Text }
-- instance EncCBOR C where
--   encCBOR (C t) = encCBOR t
-- instance DecCBOR C where
--   decCBOR = C <$> decCBOR
--
-- data B = B { unB :: Text.Text }
--
-- data A = ACon Int B C
--
-- encodeA :: A -> Encode ('Closed 'Dense) A
-- encodeA (ACon i b c) = Rec ACon !> To i !> E (encCBOR . unB) b !> To c
--
-- decodeA :: Decode ('Closed 'Dense) A
-- decodeA = RecD ACon <! From <! D (B <$> decCBOR) <! From
--
-- instance EncCBOR A where
--   encCBOR = encode . encodeA
-- instance DecCBOR A where
--   decCBOR = decode decodeA
-- @
--
-- An example with multiple constructors uses 'Sum', 'SumD', and 'Summands'.
--
-- @
-- data N = N1 Int | N2 B Bool | N3 A
--
-- encodeN :: N -> Encode 'Open N
-- encodeN (N1 i)    = Sum N1 0 !> To i
-- encodeN (N2 b tf) = Sum N2 1 !> E (encCBOR . unB) b !> To tf
-- encodeN (N3 a)    = Sum N3 2 !> To a
--
-- decodeN :: Decode ('Closed 'Dense) N    -- Note each clause has an 'Open decoder,
-- decodeN = Summands "N" decodeNx           -- But Summands returns a ('Closed 'Dense) decoder
--   where decodeNx 0 = SumD N1 <! From
--         decodeNx 1 = SumD N2 <! D (B <$> decCBOR) <! From
--         decodeNx 3 = SumD N3 <! From
--         decodeNx k = Invalid k
--
-- instance EncCBOR N   where encCBOR x = encode(encodeN x)
-- instance DecCBOR N where decCBOR = decode decodeN
-- @
--
-- Two examples using variants of sparse encoding for records, i.e. those datatypes with only one constructor.
-- The Virtual constructor approach using 'Summands', 'OmitC', 'Emit'.
-- The Sparse field approach using 'Keyed', 'Key' and 'Omit'. The approaches work
-- because encoders and decoders don't put
-- fields with default values in the Encoding, and reconstruct the default values on the decoding side.
-- We will illustrate the two approaches using the datatype M
--
-- @
-- data M = M Int [Bool] Text.Text
--   deriving (Show, Typeable)
--
-- a0, a1, a2, a3 :: M  -- Some illustrative examples, using things that might be given default values.
-- a0 = M 0 [] "ABC"
-- a1 = M 0 [True] "ABC"
-- a2 = M 9 [] "ABC"
-- a3 = M 9 [False] "ABC"
-- @
--
-- The virtual constructor strategy pretends there are mutiple constructors
-- Even though there is only one. We use invariants about the data to avoid
-- encoding some of the values. Note the use of 'Sum' with virtual constructor tags 0,1,2,3
--
-- @
-- encM :: M -> Encode 'Open M
-- encM (M 0 [] t) = Sum M 0 !> OmitC 0 !> OmitC [] !> To t
-- encM (M 0 bs t) = Sum M 1 !> OmitC 0 !> To bs !> To t
-- encM (M n [] t) = Sum M 2 !> To n !> OmitC [] !> To t
-- encM (M n bs t) = Sum M 3 !> To n !> To bs !> To t
--
-- decM :: Word -> Decode 'Open M
-- decM 0 = SumD M <! Emit 0 <! Emit [] <! From  -- The virtual constructors tell which fields have been Omited
-- decM 1 = SumD M <! Emit 0 <! From <! From     -- So those fields are reconstructed using 'Emit'.
-- decM 2 = SumD M <! From <! Emit [] <! From
-- decM 3 = SumD M <! From <! From <! From
-- decM n = Invalid n
--
-- instance EncCBOR M where
--   encCBOR m = encode (encM m)
--
-- instance DecCBOR M where
--   decCBOR = decode (Summands "M" decM)
-- @
--
-- The Sparse field approach uses N keys, one for each field that is not defaulted. For example
-- @(M 9 [True] (pack "hi")))@. Here zero fields are defaulted, so there should be 3 keys.
-- Encoding this example would look something like this.
--
-- @
-- [TkMapLen 3,TkInt 0,TkInt 9,TkInt 1,TkListBegin,TkBool True,TkBreak,TkInt 2,TkString "hi"]
--                   ^key            ^key                                    ^key
-- @
--
-- So the user supplies a function, that encodes every field, each field must use a unique
-- key, and fields with default values have Omit wrapped around the Key encoding.
-- The user must ensure that there is NOT an Omit on a required field. 'encM2' is an example.
--
-- @
-- encM2:: M -> Encode ('Closed 'Sparse) M
-- encM2 (M n xs t) =
--     Keyed M
--        !> Omit (== 0) (Key 0 (To n))    -- Omit if n is zero
--        !> Omit null (Key 1 (To xs))     -- Omit if xs is null
--        !> Key 2 (To t)                  -- Always encode t
-- @
--
-- To write an Decoder we must pair a decoder for each field, with a function that updates only
-- that field. We use the 'Field' GADT to construct these pairs, and we must write a function, that
-- for each field tag, picks out the correct pair. If the Encode and Decode don't agree on how the
-- tags correspond to a particular field, things will fail.
--
-- @
-- boxM :: Word -> Field M
-- boxM 0 = field update0 From
--   where
--     update0 n (M _ xs t) = M n xs t
-- boxM 1 = field update1 From
--   where
--     update1 xs (M n _ t) = M n xs t
-- boxM 2 = field update2 From
--   where
--     update2 t (M n xs _) = M n xs t
-- boxM n = invalidField n
-- @
--
-- Finally there is a new constructor for 'Decode', called 'SparseKeyed', that decodes field
-- keyed sparse objects. The user supplies an initial value and field function, and a list
-- of tags of the required fields. The initial value should have default values and
-- any well type value in required fields. If the encode function (baz above) is
-- encoded properly the required fields in the initial value should always be over
-- overwritten. If it is not written properly, or a bad encoding comes from somewhere
-- else, the intial values in the required fields might survive decoding. The list
-- of required fields is checked.
--
-- @
-- instance DecCBOR M where
--   decCBOR = decode (SparseKeyed
--                       "TT"                        -- ^ Name of the type being decoded
--                       (M 0 [] (Text.pack "a"))  -- ^ The default value
--                       boxM                      -- ^ The Field function
--                       [(2, "Stringpart")]         -- ^ The required Fields
--                     )
--
-- instance EncCBOR M where
--   encCBOR m = encode(encM2 m)
-- @
data Decode (w :: Wrapped) t where
  -- | Label the constructor of a Record-like datatype (one with exactly 1 constructor) as a Decode.
  RecD :: t -> Decode ('Closed 'Dense) t
  -- | Label the constructor of a Record-like datatype (one with multiple constructors) as an Decode.
  SumD :: t -> Decode 'Open t
  -- | Lift a Word to Decode function into a DeCode for a type with multiple constructors.
  Summands :: Text.Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
  -- | Lift a Word to Field function into a DeCode for a type with 1 constructor stored sparsely
  SparseKeyed ::
    Typeable t =>
    -- | Name of the Type (for error messages)
    String ->
    -- | The type with default values in all fields
    t ->
    -- | What to do with key in the @Word@
    (Word -> Field t) ->
    -- | Pairs of keys and Strings which must be there (default values not allowed)
    [(Word, String)] ->
    Decode ('Closed 'Dense) t
  -- | Label a (component, field, argument) as sparsely stored, which will be populated
  -- with the default value.
  KeyedD :: t -> Decode ('Closed 'Sparse) t
  -- | Label a (component, field, argument). It will be decoded using the existing
  -- DecCBOR instance at @t@
  From :: DecCBOR t => Decode w t
  -- | Label components, fields, arguments. It will be decoded using the existing
  -- DecCBORGroup instance at @t@
  FromGroup :: (EncCBORGroup t, DecCBORGroup t) => Decode w t
  -- | Label a (component, field, argument). It will be decoded using the given decoder.
  D :: (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
  -- | Apply a functional decoding (arising from 'RecD' or 'SumD') to get (type wise)
  -- smaller decoding.
  ApplyD :: Typeable a => Decode w1 (a -> t) -> Decode ('Closed d) a -> Decode w1 t
  -- | Mark a Word as a Decoding which is not a valid Decoding. Used when decoding sums
  -- that are tagged out of range.
  Invalid :: Word -> Decode w t
  -- | Used to make (Decode w) an instance of Functor.
  Map :: Typeable a => (a -> b) -> Decode w a -> Decode w b
  -- | Assert that the next thing decoded must be tagged with the given word.
  TagD :: Word -> Decode ('Closed x) t -> Decode ('Closed x) t
  -- | Decode the next thing, not by inspecting the bytes, but pulled out of thin air,
  -- returning @t@. Used in sparse decoding.
  Emit :: t -> Decode w t
  -- The next two could be generalized to any (Applicative f) rather than Annotator

  -- | Lift a @(Decode w t)@ to a @(Decode w (Annotator t))@. Used on a (component, field,
  -- argument) that was not Annotator encoded, but contained in Record or Sum which is
  -- Annotator encoded.
  Ann :: Typeable t => Decode w t -> Decode w (Annotator t)
  -- | Apply a functional decoding (arising from 'RecD' or 'SumD' that needs to be
  -- Annotator decoded) to get (type wise) smaller decoding.
  ApplyAnn ::
    (Typeable a, Typeable t) =>
    -- | A functional Decode
    Decode w1 (Annotator (a -> t)) ->
    -- | An Decoder for an Annotator
    Decode ('Closed d) (Annotator a) ->
    Decode w1 (Annotator t)
  -- | the function to Either can raise an error when applied by returning (Left errorMessage)
  ApplyErr :: Typeable a => Decode w1 (a -> Either String t) -> Decode ('Closed d) a -> Decode w1 t

infixl 4 <!

infixl 4 <*!

infixl 4 <?

-- | Infix form of @ApplyD@ with the same infixity and precedence as @($)@.
(<!) :: Typeable a => Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
Decode w1 (a -> t)
x <! :: forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed w) a
y = Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
ApplyD Decode w1 (a -> t)
x Decode ('Closed w) a
y
{-# INLINE (<!) #-}

-- | Infix form of @ApplyAnn@ with the same infixity and precedence as @($)@.
(<*!) ::
  (Typeable a, Typeable t) =>
  Decode w1 (Annotator (a -> t)) -> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
Decode w1 (Annotator (a -> t))
x <*! :: forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! Decode ('Closed d) (Annotator a)
y = Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
ApplyAnn Decode w1 (Annotator (a -> t))
x Decode ('Closed d) (Annotator a)
y
{-# INLINE (<*!) #-}

-- | Infix form of @ApplyErr@ with the same infixity and precedence as @($)@.
(<?) :: Typeable a => Decode w1 (a -> Either String t) -> Decode ('Closed d) a -> Decode w1 t
Decode w1 (a -> Either String t)
f <? :: forall a (w1 :: Wrapped) t (d :: Density).
Typeable a =>
Decode w1 (a -> Either String t)
-> Decode ('Closed d) a -> Decode w1 t
<? Decode ('Closed d) a
y = Decode w1 (a -> Either String t)
-> Decode ('Closed d) a -> Decode w1 t
forall a (w1 :: Wrapped) t (d :: Density).
Typeable a =>
Decode w1 (a -> Either String t)
-> Decode ('Closed d) a -> Decode w1 t
ApplyErr Decode w1 (a -> Either String t)
f Decode ('Closed d) a
y
{-# INLINE (<?) #-}

hsize :: forall w t. Decode w t -> Int
hsize :: forall (w :: Wrapped) t. Decode w t -> Int
hsize (Summands Text
_ Word -> Decode 'Open t
_) = Int
1
hsize (SumD t
_) = Int
0
hsize (RecD t
_) = Int
0
hsize (KeyedD t
_) = Int
0
hsize Decode w t
From = Int
1
hsize Decode w t
FromGroup = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy t -> Word
forall a. EncCBORGroup a => Proxy a -> Word
listLenBound (Proxy t -> Word) -> Proxy t -> Word
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @t
hsize (D forall s. Decoder s t
_) = Int
1
hsize (ApplyD Decode w (a -> t)
f Decode ('Closed d) 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 d) a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) 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
hsize (Emit t
_) = Int
0
hsize SparseKeyed {} = Int
1
hsize (TagD Word
_ Decode ('Closed x) t
_) = Int
1
hsize (Ann Decode w t
x) = Decode w t -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w t
x
hsize (ApplyAnn Decode w (Annotator (a -> t))
f Decode ('Closed d) (Annotator a)
x) = Decode w (Annotator (a -> t)) -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (Annotator (a -> t))
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode ('Closed d) (Annotator a) -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) (Annotator a)
x
hsize (ApplyErr Decode w (a -> Either String t)
f Decode ('Closed d) a
x) = Decode w (a -> Either String t) -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (a -> Either String t)
f Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode ('Closed d) a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
x
{-# INLINE hsize #-}

decode :: Typeable t => Decode w t -> Decoder s t
decode :: forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode w t
x = ((Int, t) -> t) -> Decoder s (Int, t) -> Decoder s t
forall a b. (a -> b) -> Decoder s a -> Decoder s b
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 t (w :: Wrapped) s.
Typeable t =>
Decode w t -> Decoder s (Int, t)
decodE Decode w t
x)
{-# INLINE decode #-}

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

decodeCount :: forall (w :: Wrapped) s t. Typeable t => Decode w t -> Int -> Decoder s (Int, t)
decodeCount :: forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount (Summands Text
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
<$> Text -> (Word -> Decoder s (Int, t)) -> Decoder s t
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
nm (Decode 'Open t -> Decoder s (Int, t)
forall t (w :: Wrapped) s.
Typeable t =>
Decode w t -> Decoder s (Int, t)
decodE (Decode 'Open t -> Decoder s (Int, t))
-> (Word -> Decode 'Open t) -> Word -> Decoder s (Int, t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Decode 'Open t
f)
decodeCount (SumD t
cn) Int
n = (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, t
cn)
decodeCount (KeyedD t
cn) Int
n = (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, t
cn)
decodeCount (RecD t
cn) 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 a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
cn))
decodeCount Decode w t
From Int
n = (Int
n,) (t -> (Int, t)) -> Decoder s t -> Decoder s (Int, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s t
forall s. Decoder s t
forall a s. DecCBOR a => Decoder s a
decCBOR
decodeCount Decode w t
FromGroup Int
n = (Int
n,) (t -> (Int, t)) -> Decoder s t -> Decoder s (Int, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s t
forall s. Decoder s t
forall a s. DecCBORGroup a => Decoder s a
decCBORGroup
decodeCount (D forall s. Decoder s t
dec) Int
n = (Int
n,) (t -> (Int, t)) -> Decoder s t -> Decoder s (Int, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s t
forall s. Decoder s t
dec
decodeCount (Invalid Word
k) Int
_ = Word -> Decoder s (Int, t)
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m 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) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w a
x Int
n; (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, a -> t
f a
y)
decodeCount (Emit t
x) Int
n = (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
x)
decodeCount (TagD Word
expectedTag Decode ('Closed x) t
decoder) Int
n = do
  Word -> Decoder s ()
forall s. Word -> Decoder s ()
assertTag Word
expectedTag
  Decode ('Closed x) t -> Int -> Decoder s (Int, t)
forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode ('Closed x) t
decoder Int
n
decodeCount (SparseKeyed String
name t
initial Word -> Field t
pick [(Word, String)]
required) 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 -> t -> (Word -> Field t) -> [(Word, String)] -> Decoder s t
forall a s.
Typeable a =>
String -> a -> (Word -> Field a) -> [(Word, String)] -> Decoder s a
decodeSparse String
name t
initial Word -> Field t
pick [(Word, String)]
required
decodeCount (Ann Decode w t
x) Int
n = do (Int
m, t
y) <- Decode w t -> Int -> Decoder s (Int, t)
forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
n; (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, t -> Annotator t
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
y)
decodeCount (ApplyAnn Decode w (Annotator (a -> t))
g Decode ('Closed d) (Annotator a)
x) Int
n = do
  (Int
i, Annotator (a -> t)
f) <- Decode w (Annotator (a -> t))
-> Int -> Decoder s (Int, Annotator (a -> t))
forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (Annotator (a -> t))
g (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode ('Closed d) (Annotator a) -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) (Annotator a)
x)
  Annotator a
y <- Decode ('Closed d) (Annotator a) -> Decoder s (Annotator a)
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
  (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, Annotator (a -> t)
f Annotator (a -> t) -> Annotator a -> Annotator t
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator a
y)
decodeCount (ApplyD Decode w (a -> t)
cn Decode ('Closed d) a
g) Int
n = do
  (Int
i, a -> t
f) <- Decode w (a -> t) -> Int -> Decoder s (Int, a -> t)
forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (a -> t)
cn (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode ('Closed d) a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
g)
  a
y <- Decode ('Closed d) a -> Decoder s a
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
  (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, a -> t
f a
y)
decodeCount (ApplyErr Decode w (a -> Either String t)
cn Decode ('Closed d) a
g) Int
n = do
  (Int
i, a -> Either String t
f) <- Decode w (a -> Either String t)
-> Int -> Decoder s (Int, a -> Either String t)
forall (w :: Wrapped) s t.
Typeable t =>
Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (a -> Either String t)
cn (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Decode ('Closed d) a -> Int
forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
g)
  a
y <- Decode ('Closed d) a -> Decoder s a
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
  case a -> Either String t
f a
y of
    Right t
z -> (Int, t) -> Decoder s (Int, t)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, t
z)
    Left String
message -> DecoderError -> Decoder s (Int, t)
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s (Int, t))
-> DecoderError -> Decoder s (Int, t)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"decoding error:" (String -> Text
Text.pack String
message)
{-# INLINE decodeCount #-}

-- The type of DecodeClosed precludes pattern match against (SumD c) as the types are different.

decodeClosed :: Typeable t => Decode ('Closed d) t -> Decoder s t
decodeClosed :: forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed (Summands Text
nm Word -> Decode 'Open t
f) = Text -> (Word -> Decoder s (Int, t)) -> Decoder s t
forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
nm (Decode 'Open t -> Decoder s (Int, t)
forall t (w :: Wrapped) s.
Typeable t =>
Decode w t -> Decoder s (Int, t)
decodE (Decode 'Open t -> Decoder s (Int, t))
-> (Word -> Decode 'Open t) -> Word -> Decoder s (Int, t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Decode 'Open t
f)
decodeClosed (KeyedD t
cn) = t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed (RecD t
cn) = t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed Decode ('Closed d) t
From = Decoder s t
forall s. Decoder s t
forall a s. DecCBOR a => Decoder s a
decCBOR
decodeClosed Decode ('Closed d) t
FromGroup = Decoder s t
forall s. Decoder s t
forall a s. DecCBORGroup a => Decoder s a
decCBORGroup
decodeClosed (D forall s. Decoder s t
dec) = Decoder s t
forall s. Decoder s t
dec
decodeClosed (ApplyD Decode ('Closed d) (a -> t)
cn Decode ('Closed d) a
g) = do
  a -> t
f <- Decode ('Closed d) (a -> t) -> Decoder s (a -> t)
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (a -> t)
cn
  a
y <- Decode ('Closed d) a -> Decoder s a
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
  t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> t
f a
y)
decodeClosed (Invalid Word
k) = Word -> Decoder s t
forall a (m :: * -> *). (Typeable a, MonadFail m) => Word -> m a
invalidKey Word
k
decodeClosed (Map a -> t
f Decode ('Closed d) 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 d) a -> Decoder s a
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
x
decodeClosed (Emit t
n) = t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
n
decodeClosed (TagD Word
expectedTag Decode ('Closed x) t
decoder) = do
  Word -> Decoder s ()
forall s. Word -> Decoder s ()
assertTag Word
expectedTag
  Decode ('Closed x) t -> Decoder s t
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed x) t
decoder
decodeClosed (SparseKeyed String
name t
initial Word -> Field t
pick [(Word, String)]
required) =
  String -> t -> (Word -> Field t) -> [(Word, String)] -> Decoder s t
forall a s.
Typeable a =>
String -> a -> (Word -> Field a) -> [(Word, String)] -> Decoder s a
decodeSparse String
name t
initial Word -> Field t
pick [(Word, String)]
required
decodeClosed (Ann Decode ('Closed d) t
x) = (t -> t) -> Decoder s t -> Decoder s t
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> t
t -> Annotator t
forall a. a -> Annotator a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decode ('Closed d) t -> Decoder s t
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) t
x)
decodeClosed (ApplyAnn Decode ('Closed d) (Annotator (a -> t))
g Decode ('Closed d) (Annotator a)
x) = do
  Annotator (a -> t)
f <- Decode ('Closed d) (Annotator (a -> t))
-> Decoder s (Annotator (a -> t))
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator (a -> t))
g
  Annotator a
y <- Decode ('Closed d) (Annotator a) -> Decoder s (Annotator a)
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
  t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (a -> t)
f Annotator (a -> t) -> Annotator a -> Annotator t
forall a b. Annotator (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator a
y)
decodeClosed (ApplyErr Decode ('Closed d) (a -> Either String t)
cn Decode ('Closed d) a
g) = do
  a -> Either String t
f <- Decode ('Closed d) (a -> Either String t)
-> Decoder s (a -> Either String t)
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (a -> Either String t)
cn
  a
y <- Decode ('Closed d) a -> Decoder s a
forall t (d :: Density) s.
Typeable t =>
Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
  case a -> Either String t
f a
y of
    Right t
z -> t -> Decoder s t
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
z
    Left String
message -> DecoderError -> Decoder s t
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s t) -> DecoderError -> Decoder s t
forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"decoding error:" (String -> Text
Text.pack String
message)
{-# INLINE decodeClosed #-}

decodeSparse ::
  Typeable a =>
  String ->
  a ->
  (Word -> Field a) ->
  [(Word, String)] ->
  Decoder s a
decodeSparse :: forall a s.
Typeable a =>
String -> a -> (Word -> Field a) -> [(Word, String)] -> Decoder s a
decodeSparse String
name a
initial Word -> Field a
pick [(Word, String)]
required = do
  Maybe Int
lenOrIndef <- Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeMapLenOrIndef
  (!a
v, Set Word
used) <- case Maybe Int
lenOrIndef of
    Just Int
len -> Int
-> a
-> (Word -> Field a)
-> Set Word
-> String
-> Decoder s (a, Set Word)
forall t s.
Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock Int
len a
initial Word -> Field a
pick Set Word
forall a. Set a
Set.empty String
name
    Maybe Int
Nothing -> a
-> (Word -> Field a)
-> Set Word
-> String
-> Decoder s (a, Set Word)
forall t s.
t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlockIndef a
initial Word -> Field a
pick Set Word
forall a. Set a
Set.empty String
name
  if ((Word, String) -> Bool) -> [(Word, String)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Word
key, String
_name) -> Word -> Set Word -> Bool
forall a. Ord a => a -> Set a -> Bool
member Word
key Set Word
used) [(Word, String)]
required
    then a -> Decoder s a
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
    else Set Word -> [(Word, String)] -> String -> Decoder s a
forall s a. Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys Set Word
used [(Word, String)]
required (TypeRep -> String
forall a. Show a => a -> String
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
initial))
{-# INLINE decodeSparse #-}

-- | Given a function that picks a Field from a key, decodes that field
--   and returns a (t -> t) transformer, which when applied, will
--   update the record with the value decoded.
applyField :: (Word -> Field t) -> Set Word -> String -> Decoder s (t -> t, Set Word)
applyField :: forall t s.
(Word -> Field t)
-> Set Word -> String -> Decoder s (t -> t, Set Word)
applyField Word -> Field t
f Set Word
seen String
name = do
  Word
tag <- Decoder s Word
forall s. Decoder s Word
decodeWord
  if Word -> Set Word -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Word
tag Set Word
seen
    then String -> Word -> Decoder s (t -> t, Set Word)
forall s a. String -> Word -> Decoder s a
duplicateKey String
name Word
tag
    else case Word -> Field t
f Word
tag of
      Field x -> t -> t
update forall s. Decoder s x
d -> Decoder s x
forall s. Decoder s x
d Decoder s x
-> (x -> Decoder s (t -> t, Set Word))
-> Decoder s (t -> t, Set Word)
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
>>= \x
v -> (t -> t, Set Word) -> Decoder s (t -> t, Set Word)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> t -> t
update x
v, Word -> Set Word -> Set Word
forall a. Ord a => a -> Set a -> Set a
insert Word
tag Set Word
seen)
{-# INLINE applyField #-}

-- | Decode a Map Block of key encoded data for type t
--   given a function that picks the right box for a given key, and an
--   initial value for the record (usually starts filled with default values).
--   The Block can be either len-encoded or block-encoded.
getSparseBlock :: Int -> t -> (Word -> Field t) -> Set Word -> String -> Decoder s (t, Set Word)
getSparseBlock :: forall t s.
Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock Int
0 t
initial Word -> Field t
_pick Set Word
seen String
_name = (t, Set Word) -> Decoder s (t, Set Word)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
initial, Set Word
seen)
getSparseBlock Int
n t
initial Word -> Field t
pick Set Word
seen String
name = do
  (t -> t
transform, Set Word
seen2) <- (Word -> Field t)
-> Set Word -> String -> Decoder s (t -> t, Set Word)
forall t s.
(Word -> Field t)
-> Set Word -> String -> Decoder s (t -> t, Set Word)
applyField Word -> Field t
pick Set Word
seen String
name
  Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
forall t s.
Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (t -> t
transform t
initial) Word -> Field t
pick Set Word
seen2 String
name
{-# INLINE getSparseBlock #-}

getSparseBlockIndef :: t -> (Word -> Field t) -> Set Word -> String -> Decoder s (t, Set Word)
getSparseBlockIndef :: forall t s.
t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlockIndef t
initial Word -> Field t
pick Set Word
seen String
name =
  Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr Decoder s Bool
-> (Bool -> Decoder s (t, Set Word)) -> Decoder s (t, Set Word)
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
>>= \case
    Bool
True -> (t, Set Word) -> Decoder s (t, Set Word)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
initial, Set Word
seen)
    Bool
False -> do
      (t -> t
transform, Set Word
seen2) <- (Word -> Field t)
-> Set Word -> String -> Decoder s (t -> t, Set Word)
forall t s.
(Word -> Field t)
-> Set Word -> String -> Decoder s (t -> t, Set Word)
applyField Word -> Field t
pick Set Word
seen String
name
      t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
forall t s.
t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlockIndef (t -> t
transform t
initial) Word -> Field t
pick Set Word
seen2 String
name
{-# INLINE getSparseBlockIndef #-}

mapCoder :: Typeable a => (a -> b) -> Decode w a -> Decode w b
mapCoder :: forall a b (w :: Wrapped).
Typeable a =>
(a -> b) -> Decode w a -> Decode w b
mapCoder a -> b
f (Map a -> a
g Decode w a
x) = (a -> b) -> Decode w a -> Decode w b
forall a b (w :: Wrapped).
Typeable a =>
(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
mapCoder a -> b
f Decode w a
x = (a -> b) -> Decode w a -> Decode w b
forall a b (w :: Wrapped).
Typeable a =>
(a -> b) -> Decode w a -> Decode w b
Map a -> b
f Decode w a
x
{-# INLINE mapCoder #-}

-- | Use `Cardano.Ledger.Binary.Coders.encodeDual` and `decodeDual`, when you want to
-- guarantee that a type has both `EncCBOR` and `FromCBR` instances.
decodeDual :: forall t. (EncCBOR t, DecCBOR t) => Decode ('Closed 'Dense) t
decodeDual :: forall t. (EncCBOR t, DecCBOR t) => Decode ('Closed 'Dense) t
decodeDual = (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D Decoder s t
forall s. Decoder s t
forall a s. DecCBOR a => Decoder s a
decCBOR
  where
    -- Enforce EncCBOR constraint on t
    _encCBOR :: Encoding
_encCBOR = t -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR (t
forall a. HasCallStack => a
undefined :: t)
{-# INLINE decodeDual #-}

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

listDecodeA ::
  Typeable x => Decode ('Closed 'Dense) (Annotator x) -> Decode ('Closed 'Dense) (Annotator [x])
listDecodeA :: forall x.
Typeable x =>
Decode ('Closed 'Dense) (Annotator x)
-> Decode ('Closed 'Dense) (Annotator [x])
listDecodeA Decode ('Closed 'Dense) (Annotator x)
dx = (forall s. Decoder s (Annotator [x]))
-> Decode ('Closed 'Dense) (Annotator [x])
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D ([Annotator x] -> Annotator [x]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([Annotator x] -> Annotator [x])
-> Decoder s [Annotator x] -> Decoder s (Annotator [x])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator x) -> Decoder s [Annotator x]
forall s a. Decoder s a -> Decoder s [a]
decodeList (Decode ('Closed 'Dense) (Annotator x) -> Decoder s (Annotator x)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))
{-# INLINE listDecodeA #-}

setDecodeA ::
  (Ord x, Typeable x) =>
  Decode ('Closed 'Dense) (Annotator x) ->
  Decode ('Closed 'Dense) (Annotator (Set x))
setDecodeA :: forall x.
(Ord x, Typeable x) =>
Decode ('Closed 'Dense) (Annotator x)
-> Decode ('Closed 'Dense) (Annotator (Set x))
setDecodeA Decode ('Closed 'Dense) (Annotator x)
dx = (forall s. Decoder s (Annotator (Set x)))
-> Decode ('Closed 'Dense) (Annotator (Set x))
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s (Annotator x) -> Decoder s (Annotator (Set x))
forall t s.
Ord t =>
Decoder s (Annotator t) -> Decoder s (Annotator (Set t))
decodeAnnSet (Decode ('Closed 'Dense) (Annotator x) -> Decoder s (Annotator x)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))
{-# INLINE setDecodeA #-}

mapDecodeA ::
  (Ord k, Typeable k, Typeable v) =>
  Decode ('Closed 'Dense) (Annotator k) ->
  Decode ('Closed 'Dense) (Annotator v) ->
  Decode ('Closed 'Dense) (Annotator (Map.Map k v))
mapDecodeA :: forall k v.
(Ord k, Typeable k, Typeable v) =>
Decode ('Closed 'Dense) (Annotator k)
-> Decode ('Closed 'Dense) (Annotator v)
-> Decode ('Closed 'Dense) (Annotator (Map k v))
mapDecodeA Decode ('Closed 'Dense) (Annotator k)
k Decode ('Closed 'Dense) (Annotator v)
v = (forall s. Decoder s (Annotator (Map k v)))
-> Decode ('Closed 'Dense) (Annotator (Map k v))
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s (Annotator k)
-> Decoder s (Annotator v) -> Decoder s (Annotator (Map k v))
forall a (t :: * -> *) s b.
(Ord a, Applicative t) =>
Decoder s (t a) -> Decoder s (t b) -> Decoder s (t (Map a b))
decodeMapTraverse (Decode ('Closed 'Dense) (Annotator k) -> Decoder s (Annotator k)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator k)
k) (Decode ('Closed 'Dense) (Annotator v) -> Decoder s (Annotator v)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator v)
v))
{-# INLINE mapDecodeA #-}

--------------------------------------------------------------------------------
-- Utility functions for working with CBOR
--------------------------------------------------------------------------------

duplicateKey :: String -> Word -> Decoder s a
duplicateKey :: forall s a. String -> Word -> Decoder s a
duplicateKey String
name Word
k =
  DecoderError -> Decoder s a
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s a) -> DecoderError -> Decoder s a
forall a b. (a -> b) -> a -> b
$
    Text -> Text -> DecoderError
DecoderErrorCustom
      Text
"Duplicate 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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" while decoding type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name)
{-# NOINLINE duplicateKey #-}

unusedRequiredKeys :: Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys :: forall s a. Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys Set Word
used [(Word, String)]
required String
name =
  DecoderError -> Decoder s a
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError (DecoderError -> Decoder s a) -> DecoderError -> Decoder s a
forall a b. (a -> b) -> a -> b
$
    Text -> Text -> DecoderError
DecoderErrorCustom
      (String -> Text
Text.pack (String
"value of type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name))
      (String -> Text
Text.pack ([(Word, String)] -> String
forall {a}. Show a => [(a, String)] -> String
message (((Word, String) -> Bool) -> [(Word, String)] -> [(Word, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Word, String) -> Bool
bad [(Word, String)]
required)))
  where
    bad :: (Word, String) -> Bool
bad (Word
k, String
_) = Bool -> Bool
not (Word -> Set Word -> Bool
forall a. Ord a => a -> Set a -> Bool
member Word
k Set Word
used)
    message :: [(a, String)] -> String
message [] = String
", not decoded."
    message [(a, String)
pair] = (a, String) -> String
forall {a}. Show a => (a, String) -> String
report (a, String)
pair String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(a, String)] -> String
message []
    message ((a, String)
pair : [(a, String)]
more) = (a, String) -> String
forall {a}. Show a => (a, String) -> String
report (a, String)
pair String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(a, String)] -> String
message [(a, String)]
more
    report :: (a, String) -> String
report (a
k, String
f) = String
"field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" with key " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
k
{-# NOINLINE unusedRequiredKeys #-}

-- | Prevent decoding until the 'Version' is at least the provided version.
guardUntilAtLeast :: DecCBOR a => String -> Version -> Decode ('Closed 'Dense) a
guardUntilAtLeast :: forall a.
DecCBOR a =>
String -> Version -> Decode ('Closed 'Dense) a
guardUntilAtLeast String
errMessage Version
v = (forall s. Decoder s a) -> Decode ('Closed 'Dense) a
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Version -> Decoder s Any -> Decoder s ()
forall s a. Version -> Decoder s a -> Decoder s ()
unlessDecoderVersionAtLeast Version
v (String -> Decoder s Any
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errMessage) Decoder s () -> Decoder s a -> Decoder s a
forall a b. Decoder s a -> Decoder s b -> Decoder s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder s a
forall s. Decoder s a
forall a s. DecCBOR a => Decoder s a
decCBOR)
{-# INLINE guardUntilAtLeast #-}