{-# 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 (
Decode (..),
(<!),
(<*!),
(<?),
decode,
decodeSparse,
Density (..),
Wrapped (..),
Field (..),
ofield,
invalidField,
field,
fieldGuarded,
fieldA,
fieldAA,
decodeDual,
listDecodeA,
mapDecodeA,
setDecodeA,
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)
data Density = Dense | Sparse
data Wrapped where
Open :: Wrapped
Closed :: Density -> Wrapped
data Field t where
Field :: (x -> t -> t) -> (forall s. Decoder s x) -> Field t
{-# INLINE field #-}
field :: (x -> t -> t) -> Decode ('Closed d) x -> Field t
field :: forall x t (d :: Density).
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field x -> t -> t
update Decode ('Closed d) x
dec = forall a t. (a -> t -> t) -> (forall s. Decoder s a) -> Field t
Field x -> t -> t
update (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)
{-# INLINE fieldGuarded #-}
fieldGuarded ::
String ->
(x -> Bool) ->
(x -> t -> t) ->
Decode ('Closed d) x ->
Field t
fieldGuarded :: forall x t (d :: Density).
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 =
forall a t. (a -> t -> t) -> (forall s. Decoder s a) -> Field t
Field
x -> t -> t
update
( forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x
x ->
x
x forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (x -> Bool
check x
x) (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failMsg)
)
{-# INLINE ofield #-}
ofield :: (StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
ofield :: forall x t (d :: Density).
(StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
ofield StrictMaybe x -> t -> t
update Decode ('Closed d) x
dec = forall a t. (a -> t -> t) -> (forall s. Decoder s a) -> Field t
Field StrictMaybe x -> t -> t
update (forall a. a -> StrictMaybe a
SJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (w :: Wrapped) t s. 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 = forall x t (d :: Density).
(x -> t -> t) -> Decode ('Closed d) x -> Field t
field (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const @t @Void) (forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n)
fieldA :: Applicative ann => (x -> t -> t) -> Decode ('Closed d) x -> Field (ann t)
fieldA :: forall (ann :: * -> *) x t (d :: Density).
Applicative ann =>
(x -> t -> t) -> Decode ('Closed d) x -> Field (ann t)
fieldA x -> t -> t
update Decode ('Closed d) x
dec = forall a t. (a -> t -> t) -> (forall s. Decoder s a) -> Field t
Field (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> t -> t
update) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)
{-# INLINE fieldA #-}
fieldAA ::
Applicative ann =>
(x -> t -> t) ->
Decode ('Closed d) (ann x) ->
Field (ann t)
fieldAA :: forall (ann :: * -> *) x t (d :: Density).
Applicative ann =>
(x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA x -> t -> t
update Decode ('Closed d) (ann x)
dec = forall a t. (a -> t -> t) -> (forall s. Decoder s a) -> Field t
Field (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> t -> t
update) (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) (ann x)
dec)
{-# INLINE fieldAA #-}
data Decode (w :: Wrapped) t where
RecD :: t -> Decode ('Closed 'Dense) t
SumD :: t -> Decode 'Open t
Summands :: Text.Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
SparseKeyed ::
Typeable t =>
String ->
t ->
(Word -> Field t) ->
[(Word, String)] ->
Decode ('Closed 'Dense) t
KeyedD :: t -> Decode ('Closed 'Sparse) t
From :: DecCBOR t => Decode w t
FromGroup :: (EncCBORGroup t, DecCBORGroup t) => Decode w t
D :: (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
ApplyD :: Decode w1 (a -> t) -> Decode ('Closed d) a -> Decode w1 t
Invalid :: Word -> Decode w t
Map :: (a -> b) -> Decode w a -> Decode w b
TagD :: Word -> Decode ('Closed x) t -> Decode ('Closed x) t
Emit :: t -> Decode w t
Ann :: Decode w t -> Decode w (Annotator t)
ApplyAnn ::
Decode w1 (Annotator (a -> t)) ->
Decode ('Closed d) (Annotator a) ->
Decode w1 (Annotator t)
ApplyErr :: Decode w1 (a -> Either String t) -> Decode ('Closed d) a -> Decode w1 t
infixl 4 <!
infixl 4 <*!
infixl 4 <?
(<!) :: Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
Decode w1 (a -> t)
x <! :: forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed w) a
y = forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
ApplyD Decode w1 (a -> t)
x Decode ('Closed w) a
y
{-# INLINE (<!) #-}
(<*!) ::
Decode w1 (Annotator (a -> t)) -> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
Decode w1 (Annotator (a -> t))
x <*! :: forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! Decode ('Closed d) (Annotator a)
y = forall (w1 :: Wrapped) a t (d :: Density).
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 (<*!) #-}
(<?) :: Decode w1 (a -> Either String t) -> Decode ('Closed d) a -> Decode w1 t
Decode w1 (a -> Either String t)
f <? :: forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (a -> Either String t)
-> Decode ('Closed d) a -> Decode w1 t
<? Decode ('Closed d) a
y = forall (w1 :: Wrapped) a t (d :: Density).
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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. EncCBORGroup a => Proxy a -> Word
listLenBound forall a b. (a -> b) -> a -> b
$ 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) = forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (a -> t)
f forall a. Num a => a -> a -> a
+ 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) = 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) = 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) = forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (Annotator (a -> t))
f forall a. Num a => a -> a -> a
+ 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) = forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode w (a -> Either String t)
f forall a. Num a => a -> a -> a
+ forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
x
{-# INLINE hsize #-}
decode :: Decode w t -> Decoder s t
decode :: forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode w t
x = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE Decode w t
x)
{-# INLINE decode #-}
decodE :: Decode w t -> Decoder s (Int, t)
decodE :: forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE Decode w t
x = forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
0
{-# INLINE decodE #-}
decodeCount :: forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount :: forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount (Summands Text
nm Word -> Decode 'Open t
f) Int
n = (Int
n forall a. Num a => a -> a -> a
+ Int
1,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
nm (forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Decode 'Open t
f)
decodeCount (SumD t
cn) Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n forall a. Num a => a -> a -> a
+ Int
1, t
cn)
decodeCount (KeyedD t
cn) Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n forall a. Num a => a -> a -> a
+ Int
1, t
cn)
decodeCount (RecD t
cn) Int
n = forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"RecD" (forall a b. a -> b -> a
const Int
n) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
n, t
cn))
decodeCount Decode w t
From Int
n = (Int
n,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
decodeCount Decode w t
FromGroup Int
n = (Int
n,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBORGroup a => Decoder s a
decCBORGroup
decodeCount (D forall s. Decoder s t
dec) Int
n = (Int
n,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Decoder s t
dec
decodeCount (Invalid Word
k) Int
_ = forall (m :: * -> *) 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) <- forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w a
x Int
n; forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, a -> t
f a
y)
decodeCount (Emit t
x) Int
n = 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
forall s. Word -> Decoder s ()
assertTag Word
expectedTag
forall (w :: Wrapped) s 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 forall a. Num a => a -> a -> a
+ Int
1,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
n; forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, 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) <- forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (Annotator (a -> t))
g (Int
n forall a. Num a => a -> a -> a
+ forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) (Annotator a)
x)
Annotator a
y <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, Annotator (a -> t)
f 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) <- forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (a -> t)
cn (Int
n forall a. Num a => a -> a -> a
+ forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
g)
a
y <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
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) <- forall (w :: Wrapped) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w (a -> Either String t)
cn (Int
n forall a. Num a => a -> a -> a
+ forall (w :: Wrapped) t. Decode w t -> Int
hsize Decode ('Closed d) a
g)
a
y <- forall (d :: Density) t s. 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, t
z)
Left String
message -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Text -> DecoderError
DecoderErrorCustom Text
"decoding error:" (String -> Text
Text.pack String
message)
{-# INLINE decodeCount #-}
decodeClosed :: Decode ('Closed d) t -> Decoder s t
decodeClosed :: forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed (Summands Text
nm Word -> Decode 'Open t
f) = forall s a. Text -> (Word -> Decoder s (Int, a)) -> Decoder s a
decodeRecordSum Text
nm (forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Decode 'Open t
f)
decodeClosed (KeyedD t
cn) = forall (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed (RecD t
cn) = forall (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed Decode ('Closed d) t
From = forall a s. DecCBOR a => Decoder s a
decCBOR
decodeClosed Decode ('Closed d) t
FromGroup = forall a s. DecCBORGroup a => Decoder s a
decCBORGroup
decodeClosed (D forall s. Decoder s t
dec) = forall s. Decoder s t
dec
decodeClosed (ApplyD Decode ('Closed d) (a -> t)
cn Decode ('Closed d) a
g) = do
a -> t
f <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (a -> t)
cn
a
y <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
g
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> t
f a
y)
decodeClosed (Invalid Word
k) = forall (m :: * -> *) a. MonadFail m => Word -> m a
invalidKey Word
k
decodeClosed (Map a -> t
f Decode ('Closed d) a
x) = a -> t
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
x
decodeClosed (Emit t
n) = forall (f :: * -> *) a. Applicative f => a -> f a
pure t
n
decodeClosed (TagD Word
expectedTag Decode ('Closed x) t
decoder) = do
forall s. Word -> Decoder s ()
assertTag Word
expectedTag
forall (d :: Density) t s. 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) =
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) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (d :: Density) t s. 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 <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator (a -> t))
g
Annotator a
y <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (a -> t)
f 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 <- forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (a -> Either String t)
cn
a
y <- forall (d :: Density) t s. 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure t
z
Left String
message -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError 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 <- forall s. Decoder s (Maybe Int)
decodeMapLenOrIndef
(!a
v, Set Word
used) <- case Maybe Int
lenOrIndef of
Just Int
len -> 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 forall a. Set a
Set.empty String
name
Maybe Int
Nothing -> forall t s.
t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlockIndef a
initial Word -> Field a
pick forall a. Set a
Set.empty String
name
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Word
key, String
_name) -> forall a. Ord a => a -> Set a -> Bool
member Word
key Set Word
used) [(Word, String)]
required
then forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
else forall s a. Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys Set Word
used [(Word, String)]
required (forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a
initial))
{-# INLINE decodeSparse #-}
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 <- forall s. Decoder s Word
decodeWord
if forall a. Ord a => a -> Set a -> Bool
Set.member Word
tag Set Word
seen
then 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 -> forall s. Decoder s x
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \x
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> t -> t
update x
v, forall a. Ord a => a -> Set a -> Set a
insert Word
tag Set Word
seen)
{-# INLINE applyField #-}
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 = 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) <- 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
forall t s.
Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock (Int
n 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 =
forall s. Decoder s Bool
decodeBreakOr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
initial, Set Word
seen)
Bool
False -> do
(t -> t
transform, Set Word
seen2) <- 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
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 #-}
instance Functor (Decode w) where
fmap :: forall a b. (a -> b) -> Decode w a -> Decode w b
fmap a -> b
f (Map a -> a
g Decode w a
x) = forall a b (w :: Wrapped). (a -> b) -> Decode w a -> Decode w b
Map (a -> b
f 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 = forall a b (w :: Wrapped). (a -> b) -> Decode w a -> Decode w b
Map a -> b
f Decode w a
x
{-# INLINE fmap #-}
instance Applicative (Decode ('Closed d)) where
pure :: forall a. a -> Decode ('Closed d) a
pure = forall t (w :: Wrapped). t -> Decode w t
Emit
{-# INLINE pure #-}
Decode ('Closed d) (a -> b)
f <*> :: forall a b.
Decode ('Closed d) (a -> b)
-> Decode ('Closed d) a -> Decode ('Closed d) b
<*> Decode ('Closed d) a
x = forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
ApplyD Decode ('Closed d) (a -> b)
f Decode ('Closed d) a
x
{-# INLINE (<*>) #-}
decodeDual :: forall t. (EncCBOR t, DecCBOR t) => Decode ('Closed 'Dense) t
decodeDual :: forall t. (EncCBOR t, DecCBOR t) => Decode ('Closed 'Dense) t
decodeDual = forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D forall a s. DecCBOR a => Decoder s a
decCBOR
where
_encCBOR :: Encoding
_encCBOR = forall a. EncCBOR a => a -> Encoding
encCBOR (forall a. HasCallStack => a
undefined :: t)
{-# INLINE decodeDual #-}
listDecodeA :: Decode ('Closed 'Dense) (Annotator x) -> Decode ('Closed 'Dense) (Annotator [x])
listDecodeA :: forall x.
Decode ('Closed 'Dense) (Annotator x)
-> Decode ('Closed 'Dense) (Annotator [x])
listDecodeA Decode ('Closed 'Dense) (Annotator x)
dx = forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s a. Decoder s a -> Decoder s [a]
decodeList (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))
{-# INLINE listDecodeA #-}
setDecodeA ::
Ord x =>
Decode ('Closed 'Dense) (Annotator x) ->
Decode ('Closed 'Dense) (Annotator (Set x))
setDecodeA :: forall x.
Ord x =>
Decode ('Closed 'Dense) (Annotator x)
-> Decode ('Closed 'Dense) (Annotator (Set x))
setDecodeA Decode ('Closed 'Dense) (Annotator x)
dx = forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall t s.
Ord t =>
Decoder s (Annotator t) -> Decoder s (Annotator (Set t))
decodeAnnSet (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))
{-# INLINE setDecodeA #-}
mapDecodeA ::
Ord k =>
Decode ('Closed 'Dense) (Annotator k) ->
Decode ('Closed 'Dense) (Annotator v) ->
Decode ('Closed 'Dense) (Annotator (Map.Map k v))
mapDecodeA :: forall k v.
Ord k =>
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 t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall a (t :: * -> *) s b.
(Ord a, Applicative t) =>
Decoder s (t a) -> Decoder s (t b) -> Decoder s (t (Map a b))
decodeMapTraverse (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator k)
k) (forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator v)
v))
{-# INLINE mapDecodeA #-}
duplicateKey :: String -> Word -> Decoder s a
duplicateKey :: forall s a. String -> Word -> Decoder s a
duplicateKey String
name Word
k =
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$
Text -> Text -> DecoderError
DecoderErrorCustom
Text
"Duplicate key:"
(String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Word
k forall a. [a] -> [a] -> [a]
++ String
" while decoding type " 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 =
forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$
Text -> Text -> DecoderError
DecoderErrorCustom
(String -> Text
Text.pack (String
"value of type " forall a. [a] -> [a] -> [a]
++ String
name))
(String -> Text
Text.pack (forall {a}. Show a => [(a, String)] -> String
message (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 (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] = forall {a}. Show a => (a, String) -> String
report (a, String)
pair forall a. [a] -> [a] -> [a]
++ [(a, String)] -> String
message []
message ((a, String)
pair : [(a, String)]
more) = forall {a}. Show a => (a, String) -> String
report (a, String)
pair forall a. [a] -> [a] -> [a]
++ String
", and " forall a. [a] -> [a] -> [a]
++ [(a, String)] -> String
message [(a, String)]
more
report :: (a, String) -> String
report (a
k, String
f) = String
"field " forall a. [a] -> [a] -> [a]
++ String
f forall a. [a] -> [a] -> [a]
++ String
" with key " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
k
{-# NOINLINE unusedRequiredKeys #-}
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 t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall s a. Version -> Decoder s a -> Decoder s ()
unlessDecoderVersionAtLeast Version
v (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
errMessage) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a s. DecCBOR a => Decoder s a
decCBOR)
{-# INLINE guardUntilAtLeast #-}