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


-- {-# OPTIONS_GHC  -fno-warn-orphans #-}

-- | 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(..),
    field,
    encode,
    decode,
    runE,            -- Used in testing
    decodeList,
    decodeSeq,
    decodeStrictSeq,
    decodeSet,
    decodeRecordNamed,
    decodeRecordSum,
    invalidKey,
    unusedRequiredKeys,
    duplicateKey,
    wrapCBORArray,
    encodeFoldable,
    decodeCollectionWithLen,
    decodeCollection,
    encodeFoldableEncoder,
    dualList, -- Dual values for export
    dualSeq,
    dualSet,
    dualMaybeAsList,
    dualMaybeAsNull,
    dualText,
    dualStrictSeq,
    dualCBOR,
    to,
    from,
    Decoder,
    Encoding,
    encodeNullMaybe,
    decodeNullMaybe,
    decodeSparse,
  )
where

import Cardano.Prelude (cborError)
import Control.Monad (replicateM,unless)
import Codec.CBOR.Decoding (Decoder)
import Codec.CBOR.Encoding (Encoding)
import Cardano.Binary
  ( FromCBOR (fromCBOR),
    ToCBOR (toCBOR),
    Annotator (..),
    encodeListLen,
    encodeMapLen,
    encodeWord,
    encodeBreak,
    encodeListLenIndef,
    DecoderError( DecoderErrorCustom ),
    decodeBreakOr,
    decodeListLenOrIndef,
    decodeMapLenOrIndef,
    decodeWord,
    matchSize,
    TokenType(TypeNull),
    peekTokenType,
    decodeNull,
    encodeNull,
  )
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as StrictSeq
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Sequence.Strict (StrictSeq)
import Data.Sequence (Seq)
import Data.Set (Set,insert,member)
import Data.Foldable (foldl')
import Data.Typeable

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

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

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

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

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
kString -> 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
fString -> 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

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

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

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

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

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


-- ===============================================================================
-- Encode and Decode are typed data structures which specify encoders and decoders
-- 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
-- shelley-spec-ledger-test/test/Test/Shelley/Spec/Ledger/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

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)

-- ===========================================================
-- 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
  ED :: Dual t -> t -> Encode ('Closed 'Dense) t
  OmitC :: t -> Encode w 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 (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 (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 (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 (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 Encode w t
sym = Word -> Encode w t -> Encoding
forall (w :: Wrapped) t. Word -> Encode w t -> Encoding
encodeCountPrefix Word
0 Encode w t
sym
  where
    encodeCountPrefix :: Word -> Encode w t -> Encoding
                   -- 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
_ (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 (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 (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 (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

-- ==================================================================
-- 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
  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)

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

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

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
nInt -> 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 (SparseKeyed String
name t
initial Word -> Field t
pick [(Word, String)]
required) Int
n =
   (Int
nInt -> 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)

-- 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 (\Word
x -> Decode 'Open t -> Decoder s (Int, t)
forall (w :: Wrapped) t s. Decode w t -> Decoder s (Int, t)
decodE (Word -> Decode 'Open t
f Word
x))
decodeClosed (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 = do t
x <- Decoder s t
forall a s. FromCBOR a => Decoder s a
fromCBOR; t -> Decoder s t
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
x
decodeClosed (D forall s. Decoder s t
dec) = 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 (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)

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) <- Maybe Int
-> a
-> (Word -> Field a)
-> Set Word
-> String
-> Decoder s (a, Set Word)
forall t s.
Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock Maybe Int
lenOrIndef 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 :: Maybe Int -> t -> (Word -> Field t) -> Set Word -> String -> Decoder s (t,Set Word)
getSparseBlock :: Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock (Just 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 (Just 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
   Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
forall t s.
Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock (Int -> Maybe Int
forall a. a -> Maybe a
Just(Int
nInt -> 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
getSparseBlock Maybe Int
Nothing 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
                         Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
forall t s.
Maybe Int
-> t
-> (Word -> Field t)
-> Set Word
-> String
-> Decoder s (t, Set Word)
getSparseBlock Maybe Int
forall a. Maybe a
Nothing (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 t
xs = 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 t
xs

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

-- ==================================================================
-- 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