{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# 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 (..),
    (!>),
    (<!),
    (<*!),
    (<?),
    Density (..),
    Wrapped (..),
    Annotator (..),
    Dual (..),
    Field (..),
    ofield,
    invalidField,
    field,
    fieldA,
    fieldAA,
    encode,
    decode,
    runE, -- Used in testing
    decodeList,
    decodePair,
    decodeSeq,
    decodeStrictSeq,
    decodeSet,
    decodeAnnSet,
    decodeRecordNamed,
    decodeRecordNamedT,
    decodeRecordSum,
    invalidKey,
    unusedRequiredKeys,
    duplicateKey,
    wrapCBORArray,
    encodePair,
    encodeFoldable,
    encodeFoldableAsDefinite,
    encodeFoldableAsIndefinite,
    encodeFoldableMapPairs,
    decodeCollectionWithLen,
    decodeCollection,
    encodeFoldableEncoder,
    encodeMap,
    encodeVMap,
    wrapCBORMap,
    decodeMap,
    decodeVMap,
    decodeMapNoDuplicates,
    decodeMapByKey,
    decodeMapContents,
    decodeMapTraverse,
    decodeMapContentsTraverse,
    dualList, -- Dual values for export
    dualSeq,
    dualSet,
    dualMaybeAsList,
    dualMaybeAsNull,
    dualText,
    dualStrictSeq,
    dualCBOR,
    to,
    from,
    Decoder,
    Encoding,
    encodeNullMaybe,
    encodeKeyedStrictMaybeWith,
    encodeKeyedStrictMaybe,
    decodeNullMaybe,
    decodeSparse,
    mapEncode,
    mapDecode,
    mapDecodeA,
    vMapEncode,
    vMapDecode,
    setEncode,
    setDecode,
    setDecodeA,
    listEncode,
    listDecode,
    listDecodeA,
    pairDecodeA,

    -- * Utility functions
    cborError,
  )
where

import Cardano.Binary
  ( Annotator (..),
    DecoderError (DecoderErrorCustom),
    FromCBOR (fromCBOR),
    ToCBOR (toCBOR),
    TokenType (..),
    decodeBreakOr,
    decodeListLenOrIndef,
    decodeMapLenOrIndef,
    decodeNull,
    decodeWord,
    encodeBreak,
    encodeListLen,
    encodeListLenIndef,
    encodeMapLen,
    encodeMapLenIndef,
    encodeNull,
    encodeWord,
    matchSize,
    peekTokenType,
  )
import Codec.CBOR.Decoding (Decoder, decodeTag, decodeTag64)
import Codec.CBOR.Encoding (Encoding, encodeTag)
import Control.Applicative (liftA2)
import Control.Monad (replicateM, unless, when)
import Control.Monad.Trans (MonadTrans (..))
import Control.Monad.Trans.Identity (IdentityT (runIdentityT))
import Data.Foldable (foldl')
import Data.Functor.Compose (Compose (..))
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (SJust, SNothing))
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Sequence.Strict (StrictSeq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Set (Set, insert, member)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Typeable (Typeable, typeOf)
import qualified Data.VMap as VMap
import Data.Void (Void)
import Formatting (build, formatToString)
import Formatting.Buildable (Buildable)
import qualified GHC.Exts as Exts
import Numeric.Natural (Natural)

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

decodeRecordNamed :: Text.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
  IdentityT (Decoder s) a -> Decoder s a
forall k (f :: k -> *) (a :: k). IdentityT f a -> f a
runIdentityT (IdentityT (Decoder s) a -> Decoder s a)
-> IdentityT (Decoder s) a -> Decoder s a
forall a b. (a -> b) -> a -> b
$ Text
-> (a -> Int) -> IdentityT (Decoder s) a -> IdentityT (Decoder s) a
forall (m :: (* -> *) -> * -> *) s a.
(MonadTrans m, Monad (m (Decoder s))) =>
Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
name a -> Int
getRecordSize (Decoder s a -> IdentityT (Decoder s) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s a
decoder)

decodeRecordNamedT ::
  (MonadTrans m, Monad (m (Decoder s))) =>
  Text.Text ->
  (a -> Int) ->
  m (Decoder s) a ->
  m (Decoder s) a
decodeRecordNamedT :: Text -> (a -> Int) -> m (Decoder s) a -> m (Decoder s) a
decodeRecordNamedT Text
name a -> Int
getRecordSize m (Decoder s) a
decoder = do
  Maybe Int
lenOrIndef <- Decoder s (Maybe Int) -> m (Decoder s) (Maybe Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeListLenOrIndef
  a
x <- m (Decoder s) a
decoder
  Decoder s () -> m (Decoder s) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder s () -> m (Decoder s) ())
-> Decoder s () -> m (Decoder s) ()
forall a b. (a -> b) -> a -> b
$ 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 -> m (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 ->
      let errMsg :: String
errMsg =
            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
       in Text -> Int -> Int -> Decoder s ()
forall s. Text -> Int -> Int -> Decoder s ()
matchSize (String -> Text
Text.pack String
errMsg) 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

encodeNullMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe a -> Encoding
_ Maybe a
Nothing = Encoding
encodeNull
encodeNullMaybe a -> Encoding
encoder (Just a
x) = a -> Encoding
encoder a
x

decodeNullMaybe :: Decoder s a -> Decoder s (Maybe a)
decodeNullMaybe :: Decoder s a -> Decoder s (Maybe a)
decodeNullMaybe Decoder s a
decoder = do
  Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s (Maybe a)) -> Decoder s (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    TokenType
TypeNull -> do
      Decoder s ()
forall s. Decoder s ()
decodeNull
      Maybe a -> Decoder s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    TokenType
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Decoder s a -> Decoder s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
decoder

decodePair :: Decoder s a -> Decoder s b -> Decoder s (a, b)
decodePair :: Decoder s a -> Decoder s b -> Decoder s (a, b)
decodePair Decoder s a
first Decoder s b
second = Text -> ((a, b) -> Int) -> Decoder s (a, b) -> Decoder s (a, b)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"pair" (Int -> (a, b) -> Int
forall a b. a -> b -> a
const Int
2) ((,) (a -> b -> (a, b)) -> Decoder s a -> Decoder s (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
first Decoder s (b -> (a, b)) -> Decoder s b -> Decoder s (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s b
second)

encodePair :: (a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodePair :: (a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodePair a -> Encoding
encodeFirst b -> Encoding
encodeSecond (a
x, b
y) =
  Word -> Encoding
encodeListLen Word
2
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeFirst a
x
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> b -> Encoding
encodeSecond b
y

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)

duplicateKey :: String -> Word -> Decoder s a
duplicateKey :: String -> Word -> Decoder s a
duplicateKey String
name 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
"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)

unusedRequiredKeys :: Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys :: Set Word -> [(Word, String)] -> String -> Decoder s a
unusedRequiredKeys Set Word
used [(Word, String)]
required String
name =
  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
      (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

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

decodeAnnSet :: Ord t => Decoder s (Annotator t) -> Decoder s (Annotator (Set t))
decodeAnnSet :: Decoder s (Annotator t) -> Decoder s (Annotator (Set t))
decodeAnnSet Decoder s (Annotator t)
dec = do
  [Annotator t]
xs <- Decoder s (Annotator t) -> Decoder s [Annotator t]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s (Annotator t)
dec
  Annotator (Set t) -> Decoder s (Annotator (Set t))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([t] -> Set t
forall a. Ord a => [a] -> Set a
Set.fromList ([t] -> Set t) -> Annotator [t] -> Annotator (Set t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Annotator t] -> Annotator [t]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Annotator t]
xs)

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

decodeAccWithLen ::
  Decoder s (Maybe Int) ->
  (a -> b -> b) ->
  b ->
  Decoder s a ->
  Decoder s (Int, b)
decodeAccWithLen :: Decoder s (Maybe Int)
-> (a -> b -> b) -> b -> Decoder s a -> Decoder s (Int, b)
decodeAccWithLen Decoder s (Maybe Int)
lenOrIndef a -> b -> b
combine b
acc0 Decoder s a
action = do
  Maybe Int
mLen <- Decoder s (Maybe Int)
lenOrIndef
  let condition :: Decoder s (Int -> Bool)
condition = case Maybe Int
mLen of
        Maybe Int
Nothing -> Bool -> Int -> Bool
forall a b. a -> b -> a
const (Bool -> Int -> Bool) -> Decoder s Bool -> Decoder s (Int -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Bool
forall s. Decoder s Bool
decodeBreakOr
        Just Int
len -> (Int -> Bool) -> Decoder s (Int -> Bool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len)
      loop :: Int -> b -> Decoder s (Int, b)
loop !Int
i !b
acc = do
        Int -> Bool
shouldStop <- Decoder s (Int -> Bool)
condition
        if Int -> Bool
shouldStop Int
i
          then (Int, b) -> Decoder s (Int, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, b
acc)
          else do
            a
v <- Decoder s a
action
            Int -> b -> Decoder s (Int, b)
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (a
v a -> b -> b
`combine` b
acc)
  Int -> b -> Decoder s (Int, b)
loop Int
0 b
acc0

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

encodeFoldableAsIndefinite :: (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldableAsIndefinite :: f a -> Encoding
encodeFoldableAsIndefinite = (Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoderAs Word -> Encoding -> Encoding
forall p. p -> Encoding -> Encoding
wrapArray a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  where
    wrapArray :: p -> Encoding -> Encoding
wrapArray p
_len Encoding
contents = 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

encodeFoldableAsDefinite :: (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldableAsDefinite :: f a -> Encoding
encodeFoldableAsDefinite = (Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoderAs Word -> Encoding -> Encoding
wrapArray a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  where
    wrapArray :: Word -> Encoding -> Encoding
wrapArray Word
len Encoding
contents = Word -> Encoding
encodeListLen Word
len Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents

-- Encodes a sequence of pairs as a cbor map
encodeFoldableMapPairs :: (ToCBOR a, ToCBOR b, Foldable f) => f (a, b) -> Encoding
encodeFoldableMapPairs :: f (a, b) -> Encoding
encodeFoldableMapPairs = (Word -> Encoding -> Encoding)
-> ((a, b) -> Encoding) -> f (a, b) -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoderAs Word -> Encoding -> Encoding
wrapCBORMap (((a, b) -> Encoding) -> f (a, b) -> Encoding)
-> ((a, b) -> Encoding) -> f (a, b) -> Encoding
forall a b. (a -> b) -> a -> b
$
  \(a
a, b
b) -> a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> b -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR b
b

encodeFoldableEncoder :: (Foldable f) => (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder :: (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder = (Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoderAs Word -> Encoding -> Encoding
wrapCBORArray

encodeFoldableEncoderAs ::
  (Foldable f) =>
  (Word -> Encoding -> Encoding) ->
  (a -> Encoding) ->
  f a ->
  Encoding
encodeFoldableEncoderAs :: (Word -> Encoding -> Encoding)
-> (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoderAs Word -> Encoding -> Encoding
wrap a -> Encoding
encoder f a
xs = Word -> Encoding -> Encoding
wrap 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

-- ===============================================================
-- We want to make a uniform way of encoding and decoding Map.Map
-- Unfortuantely the ToCBOR and FromCBOR instances date to Byron
-- Era, which are not always cannonical. We want to make these
-- cannonical improvements easy to use.

encodeVMap ::
  (VMap.Vector vk k, VMap.Vector vv v) =>
  (k -> Encoding) ->
  (v -> Encoding) ->
  VMap.VMap vk vv k v ->
  Encoding
encodeVMap :: (k -> Encoding) -> (v -> Encoding) -> VMap vk vv k v -> Encoding
encodeVMap k -> Encoding
encodeKey v -> Encoding
encodeValue VMap vk vv k v
vmap =
  let l :: Word
l = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ VMap vk vv k v -> Int
forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size VMap vk vv k v
vmap
      contents :: Encoding
contents = (k -> v -> Encoding) -> VMap vk vv k v -> Encoding
forall (kv :: * -> *) k (vv :: * -> *) v m.
(Vector kv k, Vector vv v, Monoid m) =>
(k -> v -> m) -> VMap kv vv k v -> m
VMap.foldMapWithKey (\k
k v
v -> k -> Encoding
encodeKey k
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> v -> Encoding
encodeValue v
v) VMap vk vv k v
vmap
   in Word -> Encoding -> Encoding
wrapCBORMap Word
l Encoding
contents

encodeMap :: (a -> Encoding) -> (b -> Encoding) -> Map.Map a b -> Encoding
encodeMap :: (a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding
encodeMap a -> Encoding
encodeKey b -> Encoding
encodeValue Map a b
m =
  let l :: Word
l = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Map a b -> Int
forall k a. Map k a -> Int
Map.size Map a b
m
      contents :: Encoding
contents = (a -> b -> Encoding) -> Map a b -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey (\a
k b
v -> a -> Encoding
encodeKey a
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> b -> Encoding
encodeValue b
v) Map a b
m
   in Word -> Encoding -> Encoding
wrapCBORMap Word
l Encoding
contents

wrapCBORMap :: Word -> Encoding -> Encoding
wrapCBORMap :: Word -> Encoding -> Encoding
wrapCBORMap Word
len Encoding
contents =
  if Word
len Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
23
    then Word -> Encoding
encodeMapLen Word
len Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents
    else Encoding
encodeMapLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeBreak

decodeVMap ::
  (VMap.Vector kv k, VMap.Vector vv v, Ord k) =>
  Decoder s k ->
  Decoder s v ->
  Decoder s (VMap.VMap kv vv k v)
decodeVMap :: Decoder s k -> Decoder s v -> Decoder s (VMap kv vv k v)
decodeVMap Decoder s k
decodeKey Decoder s v
decodeValue = Decoder s k -> (k -> Decoder s v) -> Decoder s (VMap kv vv k v)
forall t k v s.
(IsList t, Item t ~ (k, v)) =>
Decoder s k -> (k -> Decoder s v) -> Decoder s t
decodeMapByKey Decoder s k
decodeKey (Decoder s v -> k -> Decoder s v
forall a b. a -> b -> a
const Decoder s v
decodeValue)

decodeMap :: Ord a => Decoder s a -> Decoder s b -> Decoder s (Map.Map a b)
decodeMap :: Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMap Decoder s a
decodeKey Decoder s b
decodeValue = Decoder s a -> (a -> Decoder s b) -> Decoder s (Map a b)
forall t k v s.
(IsList t, Item t ~ (k, v)) =>
Decoder s k -> (k -> Decoder s v) -> Decoder s t
decodeMapByKey Decoder s a
decodeKey (Decoder s b -> a -> Decoder s b
forall a b. a -> b -> a
const Decoder s b
decodeValue)

-- | Just like `decodeMap`, but assumes there are no duplicate keys
decodeMapNoDuplicates :: Ord a => Decoder s a -> Decoder s b -> Decoder s (Map.Map a b)
decodeMapNoDuplicates :: Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMapNoDuplicates Decoder s a
decodeKey Decoder s b
decodeValue =
  (Int, Map a b) -> Map a b
forall a b. (a, b) -> b
snd
    ((Int, Map a b) -> Map a b)
-> Decoder s (Int, Map a b) -> Decoder s (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Maybe Int)
-> ((a, b) -> Map a b -> Map a b)
-> Map a b
-> Decoder s (a, b)
-> Decoder s (Int, Map a b)
forall s a b.
Decoder s (Maybe Int)
-> (a -> b -> b) -> b -> Decoder s a -> Decoder s (Int, b)
decodeAccWithLen
      Decoder s (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeMapLenOrIndef
      ((a -> b -> Map a b -> Map a b) -> (a, b) -> Map a b -> Map a b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> b -> Map a b -> Map a b
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert)
      Map a b
forall k a. Map k a
Map.empty
      Decoder s (a, b)
decodeInlinedPair
  where
    decodeInlinedPair :: Decoder s (a, b)
decodeInlinedPair = do
      !a
key <- Decoder s a
decodeKey
      !b
value <- Decoder s b
decodeValue
      (a, b) -> Decoder s (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
key, b
value)

decodeMapByKey ::
  (Exts.IsList t, Exts.Item t ~ (k, v)) =>
  Decoder s k ->
  (k -> Decoder s v) ->
  Decoder s t
decodeMapByKey :: Decoder s k -> (k -> Decoder s v) -> Decoder s t
decodeMapByKey Decoder s k
decodeKey k -> Decoder s v
decodeValueFor =
  [(k, v)] -> t
forall l. IsList l => [Item l] -> l
Exts.fromList
    ([(k, v)] -> t) -> Decoder s [(k, v)] -> Decoder s t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (k, v) -> Decoder s [(k, v)]
forall s a. Decoder s a -> Decoder s [a]
decodeMapContents Decoder s (k, v)
decodeInlinedPair
  where
    decodeInlinedPair :: Decoder s (k, v)
decodeInlinedPair = do
      !k
key <- Decoder s k
decodeKey
      !v
value <- k -> Decoder s v
decodeValueFor k
key
      (k, v) -> Decoder s (k, v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (k
key, v
value)

decodeMapContents :: Decoder s a -> Decoder s [a]
decodeMapContents :: Decoder s a -> Decoder s [a]
decodeMapContents = 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)
decodeMapLenOrIndef

decodeMapTraverse ::
  (Ord a, Applicative t) =>
  Decoder s (t a) ->
  Decoder s (t b) ->
  Decoder s (t (Map.Map a b))
decodeMapTraverse :: Decoder s (t a) -> Decoder s (t b) -> Decoder s (t (Map a b))
decodeMapTraverse Decoder s (t a)
decodeKey Decoder s (t b)
decodeValue =
  ([(a, b)] -> Map a b) -> t [(a, b)] -> t (Map a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, b)] -> Map a b
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (t [(a, b)] -> t (Map a b))
-> Decoder s (t [(a, b)]) -> Decoder s (t (Map a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (t a) -> Decoder s (t b) -> Decoder s (t [(a, b)])
forall (t :: * -> *) s a b.
Applicative t =>
Decoder s (t a) -> Decoder s (t b) -> Decoder s (t [(a, b)])
decodeMapContentsTraverse Decoder s (t a)
decodeKey Decoder s (t b)
decodeValue

decodeMapContentsTraverse ::
  (Applicative t) =>
  Decoder s (t a) ->
  Decoder s (t b) ->
  Decoder s (t [(a, b)])
decodeMapContentsTraverse :: Decoder s (t a) -> Decoder s (t b) -> Decoder s (t [(a, b)])
decodeMapContentsTraverse Decoder s (t a)
decodeKey Decoder s (t b)
decodeValue =
  [t (a, b)] -> t [(a, b)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA ([t (a, b)] -> t [(a, b)])
-> Decoder s [t (a, b)] -> Decoder s (t [(a, b)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (t (a, b)) -> Decoder s [t (a, b)]
forall s a. Decoder s a -> Decoder s [a]
decodeMapContents Decoder s (t (a, b))
decodeInlinedPair
  where
    decodeInlinedPair :: Decoder s (t (a, b))
decodeInlinedPair = Compose (Decoder s) t (a, b) -> Decoder s (t (a, b))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Decoder s) t (a, b) -> Decoder s (t (a, b)))
-> Compose (Decoder s) t (a, b) -> Decoder s (t (a, b))
forall a b. (a -> b) -> a -> b
$ (,) (a -> b -> (a, b))
-> Compose (Decoder s) t a -> Compose (Decoder s) t (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (t a) -> Compose (Decoder s) t a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Decoder s (t a)
decodeKey Compose (Decoder s) t (b -> (a, b))
-> Compose (Decoder s) t b -> Compose (Decoder s) t (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (t b) -> Compose (Decoder s) t b
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Decoder s (t b)
decodeValue

-- ===============================================================================
-- 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 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 are meant to specify the encoding and decoding of
-- Algebraic datatypes in a uniform way. (Decode t) is dual to (Encode t). In some cases
-- a decoder can be extracted from an encoder by visual inspection. We now give some
-- examples. In the examples Let Int and C have ToCBOR instances, and dualB :: Dual B
{-
-- An example with 1 constructor (a record) uses Rec and RecD

data C = C Text.Text
instance ToCBOR C where toCBOR (C t) = toCBOR t
instance FromCBOR C where fromCBOR = C <$> fromCBOR

data B = B Text.Text
dualB = Dual (\ (B t) ->toCBOR t) (B <$> fromCBOR)

data A = ACon Int B C

encodeA :: A -> Encode ('Closed 'Dense) A
encodeA (ACon i b c) = Rec ACon !> To i !> ED dualB b !> To c

decodeA :: Decode ('Closed 'Dense) A
decodeA = RecD ACon <! From <! DD dualB <! 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 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 !> ED dualB 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 <! DD dualB <! From
        decodeNx 3 = SumD N3 <! From
        decodeNx k = Invalid k

instance ToCBOR N   where toCBOR x = encode(encodeN x)
instance FromCBOR N where fromCBOR = decode decodeN
-}
-- For more examples writing CBOR instances using Encode and Decode, including
-- ones using Sparse encoding, see the test file
-- cardano-ledger-shelley-test/test/Test/Cardano/Ledger/Shelley/Coders.hs

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

-- | 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 Summand and SparseKeyed. In another dimension records 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.

-- | Record density (all the fields) vs (some of the fields)
data Density = Dense | Sparse

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

-- | Analogous to paired ToCBOR and FromCBOR instances with out freezing out
--   alternate ways to code. Unlike ToCBOR and FromCBOR where there is only
--   one instance per type. There can be multiple Duals with the same type.
data Dual t = Dual (t -> Encoding) (forall s. Decoder s t)

-- | 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 :: (x -> t -> t) -> Decode ('Closed d) x -> Field t
field :: (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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)

{-# INLINE ofield #-}
ofield :: (StrictMaybe x -> t -> t) -> Decode ('Closed d) x -> Field t
ofield :: (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 (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 :: Word -> Field t
invalidField Word
n = (Void -> t -> t) -> Decode ('Closed Any) Void -> Field t
forall x t (d :: Density).
(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
$ t -> Void -> t
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)

-- In order to sparse decode something with a (FromCBOR (Annotator t)) instance
-- we can use these 'field' like functions.

fieldA :: Applicative ann => (x -> t -> t) -> Decode ('Closed d) x -> Field (ann t)
fieldA :: (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 (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 x -> t -> t
update) (x -> ann x
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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) x
dec)

fieldAA :: Applicative ann => (x -> t -> t) -> Decode ('Closed d) (ann x) -> Field (ann t)
fieldAA :: (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 (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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed d) (ann x)
dec)

-- ===========================================================
-- The coders and the decoders as GADT datatypes
-- ===========================================================

data Encode (w :: Wrapped) t where
  Rec :: t -> Encode ('Closed 'Dense) t -- Constructor of normal Record (1 constructor)
  Sum :: t -> Word -> Encode 'Open t -- One Constructor of many
  Keyed :: t -> Encode ('Closed 'Sparse) t -- One Constructor with sparse encoding
  To :: ToCBOR a => a -> Encode ('Closed 'Dense) a
  E :: (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
  MapE :: (a -> b) -> Encode w a -> Encode w b
  ED :: Dual t -> t -> Encode ('Closed 'Dense) t
  OmitC :: t -> Encode w t
  Tag :: Word -> Encode ('Closed x) t -> Encode ('Closed x) t
  Omit :: (t -> Bool) -> Encode ('Closed 'Sparse) t -> Encode ('Closed 'Sparse) t
  Key :: Word -> Encode ('Closed 'Dense) t -> Encode ('Closed 'Sparse) t
  ApplyE :: Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t

-- The Wrapped index of ApplyE is determined by the index
-- at the bottom of its left spine. The choices are 'Open (Sum c tag),
-- ('Closed 'Dense) (Rec c), and ('Closed 'Sparse) (Keyed c).

infixl 4 !>

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

runE :: Encode w t -> t
runE :: Encode w t -> t
runE (Sum t
cn Word
_) = t
cn
runE (Rec t
cn) = t
cn
runE (ApplyE Encode w (a -> t)
f Encode ('Closed r) a
x) = Encode w (a -> t) -> a -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode w (a -> t)
f (Encode ('Closed r) a -> a
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed r) a
x)
runE (To t
x) = t
x
runE (E t -> Encoding
_ t
x) = t
x
runE (MapE a -> t
f Encode w a
x) = a -> t
f (a -> t) -> a -> t
forall a b. (a -> b) -> a -> b
$ Encode w a -> a
forall (w :: Wrapped) t. Encode w t -> t
runE Encode w a
x
runE (ED Dual t
_ t
x) = t
x
runE (OmitC t
x) = t
x
runE (Omit t -> Bool
_ Encode ('Closed 'Sparse) t
x) = Encode ('Closed 'Sparse) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed 'Sparse) t
x
runE (Tag Word
_ Encode ('Closed x) t
x) = Encode ('Closed x) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed x) t
x
runE (Key Word
_ Encode ('Closed 'Dense) t
x) = Encode ('Closed 'Dense) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed 'Dense) t
x
runE (Keyed t
cn) = t
cn

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 (MapE a -> t
_ Encode w a
x) = Encode w a -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode w a
x
gsize (ApplyE Encode w (a -> t)
f Encode ('Closed r) 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 r) a -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode ('Closed r) a
x
gsize (ED Dual t
_ t
_) = Word
1
gsize (OmitC t
_) = Word
0
gsize (Omit t -> Bool
p Encode ('Closed 'Sparse) t
x) = if t -> Bool
p (Encode ('Closed 'Sparse) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed 'Sparse) t
x) then Word
0 else Encode ('Closed 'Sparse) t -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode ('Closed 'Sparse) t
x
gsize (Tag Word
_ Encode ('Closed x) t
_) = Word
1
gsize (Key Word
_ Encode ('Closed 'Dense) t
x) = Encode ('Closed 'Dense) t -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode ('Closed 'Dense) t
x
gsize (Keyed t
_) = Word
0

encode :: Encode w t -> Encoding
encode :: Encode w t -> Encoding
encode = Word -> Encode w t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
0
  where
    encodeCountPrefix :: Word -> Encode w t -> Encoding
    -- n is the number of fields we must write in the prefix.
    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 (Keyed t
_) = Word -> Encoding
encodeMapLen Word
n
    encodeCountPrefix Word
n (Rec t
_) = Word -> Encoding
encodeListLen Word
n
    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 (MapE a -> t
_ Encode w a
x) = Word -> Encode w a -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
n Encode w a
x
    encodeCountPrefix Word
_ (ED (Dual t -> Encoding
enc forall s. Decoder s t
_) t
x) = t -> Encoding
enc t
x
    encodeCountPrefix Word
_ (OmitC t
_) = Encoding
forall a. Monoid a => a
mempty
    encodeCountPrefix Word
n (Tag Word
tag Encode ('Closed x) t
x) = Word -> Encoding
encodeTag Word
tag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encode ('Closed x) t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
n Encode ('Closed x) t
x
    encodeCountPrefix Word
n (Key Word
tag Encode ('Closed 'Dense) t
x) = Word -> Encoding
encodeWord Word
tag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encode ('Closed 'Dense) t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
n Encode ('Closed 'Dense) t
x
    encodeCountPrefix Word
n (Omit t -> Bool
p Encode ('Closed 'Sparse) t
x) =
      if t -> Bool
p (Encode ('Closed 'Sparse) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed 'Sparse) t
x) then Encoding
forall a. Monoid a => a
mempty else Word -> Encode ('Closed 'Sparse) t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
n Encode ('Closed 'Sparse) t
x
    encodeCountPrefix Word
n (ApplyE Encode w (a -> t)
ff Encode ('Closed r) a
xx) = 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 r) a -> Word
forall (w :: Wrapped) t. Encode w t -> Word
gsize Encode ('Closed r) a
xx) Encode w (a -> t)
ff Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode ('Closed r) a -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed r) a
xx
      where
        encodeClosed :: Encode ('Closed d) t -> Encoding
        encodeClosed :: Encode ('Closed d) 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 (MapE a -> t
_ Encode ('Closed d) a
x) = Encode ('Closed d) a -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed d) a
x
        encodeClosed (ApplyE Encode ('Closed d) (a -> t)
f Encode ('Closed r) a
x) = Encode ('Closed d) (a -> t) -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed d) (a -> t)
f Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode ('Closed r) a -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed r) a
x
        encodeClosed (ED (Dual t -> Encoding
enc forall s. Decoder s t
_) t
x) = t -> Encoding
enc t
x
        encodeClosed (OmitC t
_) = Encoding
forall a. Monoid a => a
mempty
        encodeClosed (Omit t -> Bool
p Encode ('Closed 'Sparse) t
x) =
          if t -> Bool
p (Encode ('Closed 'Sparse) t -> t
forall (w :: Wrapped) t. Encode w t -> t
runE Encode ('Closed 'Sparse) t
x) then Encoding
forall a. Monoid a => a
mempty else Encode ('Closed 'Sparse) t -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed 'Sparse) t
x
        encodeClosed (Tag Word
tag Encode ('Closed x) t
x) = Word -> Encoding
encodeTag Word
tag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode ('Closed x) t -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed x) t
x
        encodeClosed (Key Word
tag Encode ('Closed 'Dense) t
x) = Word -> Encoding
encodeWord Word
tag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encode ('Closed 'Dense) t -> Encoding
forall (d :: Density) t. Encode ('Closed d) t -> Encoding
encodeClosed Encode ('Closed 'Dense) t
x
        encodeClosed (Keyed t
_) = Encoding
forall a. Monoid a => a
mempty

encodeKeyedStrictMaybeWith :: Word -> (a -> Encoding) -> StrictMaybe a -> Encode ('Closed 'Sparse) (StrictMaybe a)
encodeKeyedStrictMaybeWith :: Word
-> (a -> Encoding)
-> StrictMaybe a
-> Encode ('Closed 'Sparse) (StrictMaybe a)
encodeKeyedStrictMaybeWith Word
_ a -> Encoding
_ StrictMaybe a
SNothing = StrictMaybe a -> Encode ('Closed 'Sparse) (StrictMaybe a)
forall t (w :: Wrapped). t -> Encode w t
OmitC StrictMaybe a
forall a. StrictMaybe a
SNothing
encodeKeyedStrictMaybeWith Word
key a -> Encoding
enc (SJust a
x) = Word
-> Encode ('Closed 'Dense) (StrictMaybe a)
-> Encode ('Closed 'Sparse) (StrictMaybe a)
forall t.
Word -> Encode ('Closed 'Dense) t -> Encode ('Closed 'Sparse) t
Key Word
key ((a -> StrictMaybe a)
-> Encode ('Closed 'Dense) a
-> Encode ('Closed 'Dense) (StrictMaybe a)
forall a b (w :: Wrapped). (a -> b) -> Encode w a -> Encode w b
MapE a -> StrictMaybe a
forall a. a -> StrictMaybe a
SJust (Encode ('Closed 'Dense) a
 -> Encode ('Closed 'Dense) (StrictMaybe a))
-> Encode ('Closed 'Dense) a
-> Encode ('Closed 'Dense) (StrictMaybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Encoding) -> a -> Encode ('Closed 'Dense) a
forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E a -> Encoding
enc a
x)

encodeKeyedStrictMaybe :: ToCBOR a => Word -> StrictMaybe a -> Encode ('Closed 'Sparse) (StrictMaybe a)
encodeKeyedStrictMaybe :: Word -> StrictMaybe a -> Encode ('Closed 'Sparse) (StrictMaybe a)
encodeKeyedStrictMaybe Word
key = Word
-> (a -> Encoding)
-> StrictMaybe a
-> Encode ('Closed 'Sparse) (StrictMaybe a)
forall a.
Word
-> (a -> Encoding)
-> StrictMaybe a
-> Encode ('Closed 'Sparse) (StrictMaybe a)
encodeKeyedStrictMaybeWith Word
key a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR

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

data Decode (w :: Wrapped) t where
  Summands :: String -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
  SparseKeyed :: Typeable t => String -> t -> (Word -> Field t) -> [(Word, String)] -> Decode ('Closed 'Dense) t
  SumD :: t -> Decode 'Open t
  RecD :: t -> Decode ('Closed 'Dense) t
  KeyedD :: t -> Decode ('Closed 'Sparse) t
  From :: FromCBOR 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
  DD :: Dual t -> Decode ('Closed 'Dense) t
  TagD :: Word -> Decode ('Closed x) t -> Decode ('Closed x) t
  Emit :: t -> Decode w t
  -- The next two could be generalized to any (Applicative f) rather than Annotator
  Ann :: Decode w t -> Decode w (Annotator t)
  ApplyAnn :: Decode w1 (Annotator (a -> t)) -> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
  -- A function to Either can raise an error when applied by returning (Left errorMessage)
  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 <! :: 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 (w1 :: Wrapped) a t (d :: Density).
Decode w1 (a -> t) -> Decode ('Closed d) a -> Decode w1 t
ApplyD Decode w1 (a -> t)
x Decode ('Closed w) a
y

(<*!) :: Decode w1 (Annotator (a -> t)) -> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
Decode w1 (Annotator (a -> t))
x <*! :: 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 (w1 :: Wrapped) a t (a :: Density).
Decode w1 (Annotator (a -> t))
-> Decode ('Closed a) (Annotator a) -> Decode w1 (Annotator t)
ApplyAnn Decode w1 (Annotator (a -> t))
x Decode ('Closed d) (Annotator a)
y

(<?) :: Decode w1 (a -> Either String t) -> Decode ('Closed d) a -> Decode w1 t
Decode w1 (a -> Either String t)
f <? :: 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 (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

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 (KeyedD t
_) = Int
0
hsize Decode w t
From = Int
1
hsize (D forall s. Decoder s t
_) = Int
1
hsize (DD Dual 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 String
_ t
_ Word -> Field t
_ [(Word, String)]
_) = 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

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) s t. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
0

decodeCount :: forall (w :: Wrapped) s t. 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
cn) 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
cn)
decodeCount (KeyedD t
cn) 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
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 (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 a s. FromCBOR a => Decoder s a
fromCBOR
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 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) s t. 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)
decodeCount (DD (Dual t -> Encoding
_enc 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 (Emit t
x) Int
n = (Int, t) -> Decoder s (Int, t)
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. 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. Decode w t -> Int -> Decoder s (Int, t)
decodeCount Decode w t
x Int
n; (Int, Annotator t) -> Decoder s (Int, Annotator t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
m, t -> Annotator t
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. 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 (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
  (Int, Annotator t) -> Decoder s (Int, Annotator t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, Annotator (a -> t)
f Annotator (a -> t) -> Annotator a -> Annotator t
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. 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 (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) 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 (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. 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 (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 -> (Int, t) -> Decoder s (Int, t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, t
z)
    Left String
message -> DecoderError -> Decoder s (Int, t)
forall e s a. Buildable e => e -> Decoder s 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)

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

decodeClosed :: Decode ('Closed d) t -> Decoder s t
decodeClosed :: Decode ('Closed d) 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 (Decode 'Open t -> Decoder s (Int, t)
forall (w :: Wrapped) t s. 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 (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed (RecD t
cn) = t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
cn
decodeClosed Decode ('Closed d) t
From = Decoder s t
forall a s. FromCBOR a => Decoder s a
fromCBOR
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 (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (a -> t)
cn
  a
y <- Decode ('Closed d) a -> Decoder s a
forall (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) 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 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 (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) a
x
decodeClosed (DD (Dual t -> Encoding
_enc forall s. Decoder s t
dec)) = Decoder s t
forall s. Decoder s t
dec
decodeClosed (Emit t
n) = t -> Decoder s t
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 (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) =
  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 -> Annotator t) -> Decoder s t -> Decoder s (Annotator t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t -> Annotator t
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decode ('Closed d) t -> Decoder s t
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 <- Decode ('Closed d) (Annotator (a -> t))
-> Decoder s (Annotator (a -> t))
forall (d :: Density) t s. 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 (d :: Density) t s. Decode ('Closed d) t -> Decoder s t
decodeClosed Decode ('Closed d) (Annotator a)
x
  Annotator t -> Decoder s (Annotator t)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Annotator (a -> t)
f Annotator (a -> t) -> Annotator a -> Annotator t
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 (d :: Density) t s. 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 (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 -> t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
z
    Left String
message -> DecoderError -> Decoder s t
forall e s a. Buildable e => e -> Decoder s 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)

decodeSparse ::
  Typeable a =>
  String ->
  a ->
  (Word -> Field a) ->
  [(Word, String)] ->
  Decoder s a
decodeSparse :: 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 (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))

-- | 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 :: (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 -> do x
v <- Decoder s x
forall s. Decoder s x
d; (t -> t, Set Word) -> Decoder s (t -> t, Set Word)
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)

-- | 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 :: 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 (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

getSparseBlockIndef :: t -> (Word -> Field t) -> Set Word -> String -> Decoder s (t, Set Word)
getSparseBlockIndef :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True -> (t, Set Word) -> Decoder s (t, Set Word)
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

-- ======================================================
-- (Decode ('Closed 'Dense)) and (Decode ('Closed 'Sparse)) are applicative
-- (Decode 'Open) is not applicative since there is no
-- (Applys 'Open 'Open) instance. And there should never be one.

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

instance Applicative (Decode ('Closed d)) where
  pure :: a -> Decode ('Closed d) a
pure a
x = a -> Decode ('Closed d) a
forall t (w :: Wrapped). t -> Decode w t
Emit a
x
  Decode ('Closed d) (a -> b)
f <*> :: Decode ('Closed d) (a -> b)
-> Decode ('Closed d) a -> Decode ('Closed d) b
<*> Decode ('Closed d) a
x = Decode ('Closed d) (a -> b)
-> Decode ('Closed d) a -> Decode ('Closed d) b
forall (w1 :: Wrapped) a t (d :: Density).
Decode w1 (a -> t) -> Decode ('Closed d) a -> Decode w1 t
ApplyD Decode ('Closed d) (a -> b)
f Decode ('Closed d) a
x

-- ===========================================================================================
-- A Dual pairs an Encoding and a Decoder with a roundtrip property.
-- They are used with the (E and D) constructors of Encode and Decode
-- If you are trying to code something not in the CBOR classes
-- or you want something not traditional, make you own Dual and use E or D

-- data Dual t = Dual (t -> Encoding) (forall s . Decoder s t)

dualList :: (ToCBOR a, FromCBOR a) => Dual [a]
dualList :: Dual [a]
dualList = ([a] -> Encoding) -> (forall s. Decoder s [a]) -> Dual [a]
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual [a] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable (Decoder s a -> Decoder s [a]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR)

dualSeq :: (ToCBOR a, FromCBOR a) => Dual (Seq a)
dualSeq :: Dual (Seq a)
dualSeq = (Seq a -> Encoding)
-> (forall s. Decoder s (Seq a)) -> Dual (Seq a)
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual Seq a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable (Decoder s a -> Decoder s (Seq a)
forall s a. Decoder s a -> Decoder s (Seq a)
decodeSeq Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR)

dualSet :: (Ord a, ToCBOR a, FromCBOR a) => Dual (Set a)
dualSet :: Dual (Set a)
dualSet = (Set a -> Encoding)
-> (forall s. Decoder s (Set a)) -> Dual (Set a)
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual Set a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable (Decoder s a -> Decoder s (Set a)
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR)

-- | Good for encoding (Maybe t) if is another Maybe. Uses more space than dualMaybeAsNull
dualMaybeAsList :: (ToCBOR a, FromCBOR a) => Dual (Maybe a)
dualMaybeAsList :: Dual (Maybe a)
dualMaybeAsList = (Maybe a -> Encoding)
-> (forall s. Decoder s (Maybe a)) -> Dual (Maybe a)
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual Maybe a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR forall s. Decoder s (Maybe a)
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Good for encoding (Maybe T) as long as T isn't another Maybe
dualMaybeAsNull :: (ToCBOR a, FromCBOR a) => Dual (Maybe a)
dualMaybeAsNull :: Dual (Maybe a)
dualMaybeAsNull = (Maybe a -> Encoding)
-> (forall s. Decoder s (Maybe a)) -> Dual (Maybe a)
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual ((a -> Encoding) -> Maybe a -> Encoding
forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR) (Decoder s a -> Decoder s (Maybe a)
forall s a. Decoder s a -> Decoder s (Maybe a)
decodeNullMaybe Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR)

dualStrictSeq :: (ToCBOR a, FromCBOR a) => Dual (StrictSeq a)
dualStrictSeq :: Dual (StrictSeq a)
dualStrictSeq = (StrictSeq a -> Encoding)
-> (forall s. Decoder s (StrictSeq a)) -> Dual (StrictSeq a)
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual StrictSeq a -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable (Decoder s a -> Decoder s (StrictSeq a)
forall s a. Decoder s a -> Decoder s (StrictSeq a)
decodeStrictSeq Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR)

dualText :: Dual Text.Text
dualText :: Dual Text
dualText = (Text -> Encoding) -> (forall s. Decoder s Text) -> Dual Text
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR

dualCBOR :: (ToCBOR a, FromCBOR a) => Dual a
dualCBOR :: Dual a
dualCBOR = (a -> Encoding) -> (forall s. Decoder s a) -> Dual a
forall t. (t -> Encoding) -> (forall s. Decoder s t) -> Dual t
Dual a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- Use to and from, when you want to guarantee that a type has both
-- ToCBOR and FromCBR instances.

to :: (ToCBOR t, FromCBOR t) => t -> Encode ('Closed 'Dense) t
to :: t -> Encode ('Closed 'Dense) t
to = Dual t -> t -> Encode ('Closed 'Dense) t
forall t. Dual t -> t -> Encode ('Closed 'Dense) t
ED Dual t
forall a. (ToCBOR a, FromCBOR a) => Dual a
dualCBOR

from :: (ToCBOR t, FromCBOR t) => Decode ('Closed 'Dense) t
from :: Decode ('Closed 'Dense) t
from = Dual t -> Decode ('Closed 'Dense) t
forall t. Dual t -> Decode ('Closed 'Dense) t
DD Dual t
forall a. (ToCBOR a, FromCBOR a) => Dual a
dualCBOR

-- ==================================================================
-- Combinators for building ({En|De}code ('Closed 'Dense) x) objects.
-- The use of "encodeFoldable" is not self-documenting at all (and
-- not even correct for Maps, even though Map is an instance of Foldable)
-- So instead of writing:  (E encodeFoldable x), we want people to write:
-- 1) (mapEncode x)   if x is a Map
-- 2) (setEncode x)   if x is a Set
-- 3) (listEncode x)  if x is a List
--
-- To decode one of these foldable instances, should use one of the aptly named Duals
--
-- 1) mapDecode   if x is a Map
-- 2) setDecode   if x is a Set
-- 3) listDecode  if x is a List
--
-- If one needs an Annotated decoder, one can use (explained further below)
--
-- 1) mapDecodeA   if x is a Map
-- 2) setDecodeA   if x is a Set
-- 3) listDecodeA  if x is a List
-- 4) pairDecodeA  if x is a Pair like (Int,Bool)

-- | (mapEncode x)  is self-documenting, correct way to encode Map. use mapDecode as its dual
mapEncode :: (ToCBOR k, ToCBOR v) => Map.Map k v -> Encode ('Closed 'Dense) (Map.Map k v)
mapEncode :: Map k v -> Encode ('Closed 'Dense) (Map k v)
mapEncode = (Map k v -> Encoding)
-> Map k v -> Encode ('Closed 'Dense) (Map k v)
forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E ((k -> Encoding) -> (v -> Encoding) -> Map k v -> Encoding
forall a b.
(a -> Encoding) -> (b -> Encoding) -> Map a b -> Encoding
encodeMap k -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR v -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR)

-- | (mapDecode) is the Dual for (mapEncode x)
mapDecode :: (Ord k, FromCBOR k, FromCBOR v) => Decode ('Closed 'Dense) (Map.Map k v)
mapDecode :: Decode ('Closed 'Dense) (Map k v)
mapDecode = (forall s. Decoder s (Map k v))
-> Decode ('Closed 'Dense) (Map k v)
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s k -> Decoder s v -> Decoder s (Map k v)
forall a s b.
Ord a =>
Decoder s a -> Decoder s b -> Decoder s (Map a b)
decodeMap Decoder s k
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s v
forall a s. FromCBOR a => Decoder s a
fromCBOR)

-- | (vMapEncode x) is self-documenting, correct way to encode VMap. use
-- vMapDecode as its dual
vMapEncode ::
  (VMap.Vector kv k, VMap.Vector vv v, ToCBOR k, ToCBOR v) =>
  VMap.VMap kv vv k v ->
  Encode ('Closed 'Dense) (VMap.VMap kv vv k v)
vMapEncode :: VMap kv vv k v -> Encode ('Closed 'Dense) (VMap kv vv k v)
vMapEncode = (VMap kv vv k v -> Encoding)
-> VMap kv vv k v -> Encode ('Closed 'Dense) (VMap kv vv k v)
forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E ((k -> Encoding) -> (v -> Encoding) -> VMap kv vv k v -> Encoding
forall (vk :: * -> *) k (vv :: * -> *) v.
(Vector vk k, Vector vv v) =>
(k -> Encoding) -> (v -> Encoding) -> VMap vk vv k v -> Encoding
encodeVMap k -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR v -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR)

-- | (vMapDecode) is the Dual for (vMapEncode x)
vMapDecode ::
  (VMap.Vector kv k, VMap.Vector vv v, Ord k, FromCBOR k, FromCBOR v) =>
  Decode ('Closed 'Dense) (VMap.VMap kv vv k v)
vMapDecode :: Decode ('Closed 'Dense) (VMap kv vv k v)
vMapDecode = (forall s. Decoder s (VMap kv vv k v))
-> Decode ('Closed 'Dense) (VMap kv vv k v)
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s k -> Decoder s v -> Decoder s (VMap kv vv k v)
forall (kv :: * -> *) k (vv :: * -> *) v s.
(Vector kv k, Vector vv v, Ord k) =>
Decoder s k -> Decoder s v -> Decoder s (VMap kv vv k v)
decodeVMap Decoder s k
forall a s. FromCBOR a => Decoder s a
fromCBOR Decoder s v
forall a s. FromCBOR a => Decoder s a
fromCBOR)

-- | (setEncode x) is self-documenting (E encodeFoldable x), use setDecode as its dual
setEncode :: (ToCBOR v) => Set.Set v -> Encode ('Closed 'Dense) (Set.Set v)
setEncode :: Set v -> Encode ('Closed 'Dense) (Set v)
setEncode = (Set v -> Encoding) -> Set v -> Encode ('Closed 'Dense) (Set v)
forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E Set v -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

-- | (setDecode) is the Dual for (setEncode x)
setDecode :: (Ord v, FromCBOR v) => Decode ('Closed 'Dense) (Set.Set v)
setDecode :: Decode ('Closed 'Dense) (Set v)
setDecode = (forall s. Decoder s (Set v)) -> Decode ('Closed 'Dense) (Set v)
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s v -> Decoder s (Set v)
forall a s. Ord a => Decoder s a -> Decoder s (Set a)
decodeSet Decoder s v
forall a s. FromCBOR a => Decoder s a
fromCBOR)

-- | (listEncode x) is self-documenting (E encodeFoldable x), use listDecode as its dual
listEncode :: (ToCBOR v) => [v] -> Encode ('Closed 'Dense) [v]
listEncode :: [v] -> Encode ('Closed 'Dense) [v]
listEncode = ([v] -> Encoding) -> [v] -> Encode ('Closed 'Dense) [v]
forall t. (t -> Encoding) -> t -> Encode ('Closed 'Dense) t
E [v] -> Encoding
forall a (f :: * -> *). (ToCBOR a, Foldable f) => f a -> Encoding
encodeFoldable

-- | (listDecode) is the Dual for (listEncode x)
listDecode :: (FromCBOR v) => Decode ('Closed 'Dense) [v]
listDecode :: Decode ('Closed 'Dense) [v]
listDecode = (forall s. Decoder s [v]) -> Decode ('Closed 'Dense) [v]
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (Decoder s v -> Decoder s [v]
forall s a. Decoder s a -> Decoder s [a]
decodeList Decoder s v
forall a s. FromCBOR a => Decoder s a
fromCBOR)

-- =============================================================================
-- Combinators for building (Decode ('Closed 'Dense) (Annotator x)) objects. Unlike
-- the combinators above (setDecode, mapDecode, ListDecode) for Non-Annotator types,
-- these combinators take explicit (Decode  ('Closed 'Dense) i) objects as parameters
-- rather than relying on FromCBOR instances as implicit parameters. To get the
-- annotator version, just add 'A' to the end of the non-annotator version decode function.
-- E.g.  setDecodeA, listDecodeA, mapDecodeA. Suppose I want to decode x:: Map [A] (B,C)
-- and I only have Annotator instances of A and C, then the following decodes x.
-- mapDecodeA (listDecodeA From) (pairDecodeA (Ann From) From).
--                                             ^^^^^^^^
-- One can always lift x::(Decode w T) by using Ann. so (Ann x)::(Decode w (Annotator T)).

pairDecodeA ::
  Decode ('Closed 'Dense) (Annotator x) ->
  Decode ('Closed 'Dense) (Annotator y) ->
  Decode ('Closed 'Dense) (Annotator (x, y))
pairDecodeA :: Decode ('Closed 'Dense) (Annotator x)
-> Decode ('Closed 'Dense) (Annotator y)
-> Decode ('Closed 'Dense) (Annotator (x, y))
pairDecodeA Decode ('Closed 'Dense) (Annotator x)
x Decode ('Closed 'Dense) (Annotator y)
y = (forall s. Decoder s (Annotator (x, y)))
-> Decode ('Closed 'Dense) (Annotator (x, y))
forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D ((forall s. Decoder s (Annotator (x, y)))
 -> Decode ('Closed 'Dense) (Annotator (x, y)))
-> (forall s. Decoder s (Annotator (x, y)))
-> Decode ('Closed 'Dense) (Annotator (x, y))
forall a b. (a -> b) -> a -> b
$ do
  (Annotator x
xA, Annotator y
yA) <- Decoder s (Annotator x)
-> Decoder s (Annotator y) -> Decoder s (Annotator x, Annotator y)
forall s a b. Decoder s a -> Decoder s b -> Decoder s (a, b)
decodePair (Decode ('Closed 'Dense) (Annotator x) -> Decoder s (Annotator x)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
x) (Decode ('Closed 'Dense) (Annotator y) -> Decoder s (Annotator y)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator y)
y)
  Annotator (x, y) -> Decoder s (Annotator (x, y))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((,) (x -> y -> (x, y)) -> Annotator x -> Annotator (y -> (x, y))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Annotator x
xA Annotator (y -> (x, y)) -> Annotator y -> Annotator (x, y)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Annotator y
yA)

listDecodeA :: Decode ('Closed 'Dense) (Annotator x) -> Decode ('Closed 'Dense) (Annotator [x])
listDecodeA :: 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)
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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))

setDecodeA ::
  Ord x =>
  Decode ('Closed 'Dense) (Annotator x) ->
  Decode ('Closed 'Dense) (Annotator (Set x))
setDecodeA :: 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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator x)
dx))

mapDecodeA ::
  Ord k =>
  Decode ('Closed 'Dense) (Annotator k) ->
  Decode ('Closed 'Dense) (Annotator v) ->
  Decode ('Closed 'Dense) (Annotator (Map.Map k v))
mapDecodeA :: 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 (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator k)
k) (Decode ('Closed 'Dense) (Annotator v) -> Decoder s (Annotator v)
forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) (Annotator v)
v))

-- ==================================================================
-- A Guide to Visual inspection of Duality in Encode and Decode
--
-- 1) (Sum c)     and (SumD c)    are duals
-- 2) (Rec c)     and (RecD c)    are duals
-- 3) (Keyed c)   and (KeyedD c)  are duals
-- 4) (OmitC x)   and (Emit x)    are duals
-- 5) (Omit p ..) and (Emit x)    are duals if (p x) is True
-- 6) (To x)      and (From)      are duals if (x::T) and (forall (y::T). isRight (roundTrip y))
-- 7) (E enc x)   and (D dec)     are duals if (forall x . isRight (roundTrip' enc dec x))
-- 6) (ED d x)    and (DD f)      are duals as long as d=(Dual enc dec) and (forall x . isRight (roundTrip' enc dec x))
-- 7) f !> x      and g <! y      are duals if (f and g are duals) and (x and y are duals)
--
-- The duality of (Summands name decodeT) depends on the duality of the range of decodeT with the endoder of T
-- A some property also holds for (SparseKeyed name (init::T) pick required) depending on the keys of pick and the Sparse encoder of T

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

assertTag :: Word -> Decoder s ()
assertTag :: Word -> Decoder s ()
assertTag Word
tag = do
  Natural
t <-
    Decoder s TokenType
forall s. Decoder s TokenType
peekTokenType Decoder s TokenType
-> (TokenType -> Decoder s Natural) -> Decoder s Natural
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TokenType
TypeTag -> Word -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Natural) -> Decoder s Word -> Decoder s Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word
forall s. Decoder s Word
decodeTag
      TokenType
TypeTag64 -> Word64 -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Natural) -> Decoder s Word64 -> Decoder s Natural
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word64
forall s. Decoder s Word64
decodeTag64
      TokenType
_ -> String -> Decoder s Natural
forall e s a. Buildable e => e -> Decoder s a
cborError (String
"expected tag" :: String)
  Bool -> Decoder s () -> Decoder s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
t Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
/= (Word -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
tag :: Natural)) (Decoder s () -> Decoder s ()) -> Decoder s () -> Decoder s ()
forall a b. (a -> b) -> a -> b
$
    String -> Decoder s ()
forall e s a. Buildable e => e -> Decoder s a
cborError (String
"expecteg tag " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word -> String
forall a. Show a => a -> String
show Word
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" but got tag " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
t)

-- | Convert a @Buildable@ error into a 'cborg' decoder error
cborError :: Buildable e => e -> Decoder s a
cborError :: e -> Decoder s a
cborError = String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s a) -> (e -> String) -> e -> Decoder s a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Format String (e -> String) -> e -> String
forall a. Format String a -> a
formatToString Format String (e -> String)
forall a r. Buildable a => Format r (a -> r)
build