{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Ledger.Binary.Encoding.Encoder (
  -- * Decoders
  Encoding,
  toBuilder,
  C.Tokens (..),
  toPlainEncoding,
  fromPlainEncoding,
  fromPlainEncodingWithVersion,
  withCurrentEncodingVersion,
  enforceEncodingVersion,
  ifEncodingVersionAtLeast,

  -- ** Custom
  encodeVersion,
  encodeMaybe,
  encodeNullMaybe,
  encodeStrictMaybe,
  encodeNullStrictMaybe,
  encodeTuple,
  encodeRatio,
  encodeRatioNoTag,
  encodeRatioWithTag,
  encodeEnum,
  encodeWithOrigin,

  -- *** Containers
  encodeList,
  encodeSeq,
  encodeStrictSeq,
  encodeSet,
  encodeMap,
  encodeVMap,
  encodeVector,
  variableListLenEncoding,

  -- **** Helpers
  encodeFoldableEncoder,
  encodeFoldableAsDefLenList,
  encodeFoldableAsIndefLenList,
  encodeFoldableMapEncoder,
  lengthThreshold,

  -- *** Time
  encodeUTCTime,

  -- *** Network
  encodeIPv4,
  ipv4ToBytes,
  encodeIPv6,
  ipv6ToBytes,

  -- ** Original
  encodeWord,
  encodeWord8,
  encodeWord16,
  encodeWord32,
  encodeWord64,
  encodeInt,
  encodeInt8,
  encodeInt16,
  encodeInt32,
  encodeInt64,
  encodeInteger,
  encodeBytes,
  encodeBytesIndef,
  encodeByteArray,
  encodeString,
  encodeStringIndef,
  encodeUtf8ByteArray,
  encodeListLen,
  encodeListLenIndef,
  encodeMapLen,
  encodeMapLenIndef,
  encodeBreak,
  encodeTag,
  encodeTag64,
  encodeBool,
  encodeUndef,
  encodeNull,
  encodeSimple,
  encodeFloat16,
  encodeFloat,
  encodeDouble,
  encodePreEncoded,
  encodeTerm,
) where

import qualified Cardano.Binary as C
import Cardano.Ledger.Binary.Decoding.Decoder (setTag)
import Cardano.Ledger.Binary.Version (Version, getVersion64, natVersion)
import Cardano.Slotting.Slot (WithOrigin, withOriginToMaybe)
import Codec.CBOR.ByteArray.Sliced (SlicedByteArray)
import qualified Codec.CBOR.Term as C (Term (..), encodeTerm)
import qualified Codec.CBOR.Write as CBOR (toBuilder)
import Data.Binary.Put (putWord32le, runPut)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Lazy as BSL
import Data.Foldable as F (foldMap', foldl')
import Data.IP (IPv4, IPv6, toHostAddress, toHostAddress6)
import Data.Int (Int16, Int32, Int64, Int8)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Monoid (Sum (..))
import Data.Ratio (Ratio, denominator, numerator)
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds)
import qualified Data.VMap as VMap
import qualified Data.Vector.Generic as VG
import Data.Word (Word16, Word32, Word64, Word8)
import Prelude hiding (encodeFloat)

--------------------------------------------------------------------------------
-- Versioned Encoder
--------------------------------------------------------------------------------

newtype Encoding = Encoding (Version -> C.Encoding)
  deriving (NonEmpty Encoding -> Encoding
Encoding -> Encoding -> Encoding
(Encoding -> Encoding -> Encoding)
-> (NonEmpty Encoding -> Encoding)
-> (forall b. Integral b => b -> Encoding -> Encoding)
-> Semigroup Encoding
forall b. Integral b => b -> Encoding -> Encoding
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Encoding -> Encoding -> Encoding
<> :: Encoding -> Encoding -> Encoding
$csconcat :: NonEmpty Encoding -> Encoding
sconcat :: NonEmpty Encoding -> Encoding
$cstimes :: forall b. Integral b => b -> Encoding -> Encoding
stimes :: forall b. Integral b => b -> Encoding -> Encoding
Semigroup, Semigroup Encoding
Encoding
Semigroup Encoding =>
Encoding
-> (Encoding -> Encoding -> Encoding)
-> ([Encoding] -> Encoding)
-> Monoid Encoding
[Encoding] -> Encoding
Encoding -> Encoding -> Encoding
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Encoding
mempty :: Encoding
$cmappend :: Encoding -> Encoding -> Encoding
mappend :: Encoding -> Encoding -> Encoding
$cmconcat :: [Encoding] -> Encoding
mconcat :: [Encoding] -> Encoding
Monoid)

fromPlainEncoding :: C.Encoding -> Encoding
fromPlainEncoding :: Encoding -> Encoding
fromPlainEncoding Encoding
enc = (Version -> Encoding) -> Encoding
Encoding (Encoding -> Version -> Encoding
forall a b. a -> b -> a
const Encoding
enc)

fromPlainEncodingWithVersion :: (Version -> C.Encoding) -> Encoding
fromPlainEncodingWithVersion :: (Version -> Encoding) -> Encoding
fromPlainEncodingWithVersion = (Version -> Encoding) -> Encoding
Encoding

toPlainEncoding :: Version -> Encoding -> C.Encoding
toPlainEncoding :: Version -> Encoding -> Encoding
toPlainEncoding Version
v (Encoding Version -> Encoding
enc) = Version -> Encoding
enc Version
v

toBuilder :: Version -> Encoding -> Builder
toBuilder :: Version -> Encoding -> Builder
toBuilder Version
version (Encoding Version -> Encoding
enc) = Encoding -> Builder
CBOR.toBuilder (Encoding -> Builder) -> Encoding -> Builder
forall a b. (a -> b) -> a -> b
$ Version -> Encoding
enc Version
version

-- | Get access to the current version being used in the encoder
withCurrentEncodingVersion :: (Version -> Encoding) -> Encoding
withCurrentEncodingVersion :: (Version -> Encoding) -> Encoding
withCurrentEncodingVersion Version -> Encoding
f =
  (Version -> Encoding) -> Encoding
Encoding ((Version -> Encoding) -> Encoding)
-> (Version -> Encoding) -> Encoding
forall a b. (a -> b) -> a -> b
$ \Version
version -> Version -> Encoding -> Encoding
toPlainEncoding Version
version (Encoding -> Encoding) -> Encoding -> Encoding
forall a b. (a -> b) -> a -> b
$ Version -> Encoding
f Version
version

-- | Ignore the current version of the encoder and enforce the supplied one instead.
enforceEncodingVersion :: Version -> Encoding -> Encoding
enforceEncodingVersion :: Version -> Encoding -> Encoding
enforceEncodingVersion Version
version Encoding
encoding = Encoding -> Encoding
fromPlainEncoding (Version -> Encoding -> Encoding
toPlainEncoding Version
version Encoding
encoding)

-- | Conditionoly choose the encoder newer or older deceder, depending on the current
-- version. Supplied version acts as a pivot.
--
-- =====__Example__
ifEncodingVersionAtLeast ::
  Version ->
  -- | Use this encoder if current encoder version is larger or equal to the supplied
  -- `Version`
  Encoding ->
  -- | Use this encoder if current encoder version is lower than the supplied `Version`
  Encoding ->
  Encoding
ifEncodingVersionAtLeast :: Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast Version
atLeast (Encoding Version -> Encoding
newerEncoding) (Encoding Version -> Encoding
olderEncoding) =
  (Version -> Encoding) -> Encoding
Encoding ((Version -> Encoding) -> Encoding)
-> (Version -> Encoding) -> Encoding
forall a b. (a -> b) -> a -> b
$ \Version
cur ->
    if Version
cur Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
atLeast
      then Version -> Encoding
newerEncoding Version
cur
      else Version -> Encoding
olderEncoding Version
cur

--------------------------------------------------------------------------------
-- Wrapped CBORG encoders
--------------------------------------------------------------------------------

encodeWord :: Word -> Encoding
encodeWord :: Word -> Encoding
encodeWord Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeWord Word
e)

encodeWord8 :: Word8 -> Encoding
encodeWord8 :: Word8 -> Encoding
encodeWord8 Word8
e = Encoding -> Encoding
fromPlainEncoding (Word8 -> Encoding
C.encodeWord8 Word8
e)

encodeWord16 :: Word16 -> Encoding
encodeWord16 :: Word16 -> Encoding
encodeWord16 Word16
e = Encoding -> Encoding
fromPlainEncoding (Word16 -> Encoding
C.encodeWord16 Word16
e)

encodeWord32 :: Word32 -> Encoding
encodeWord32 :: Word32 -> Encoding
encodeWord32 Word32
e = Encoding -> Encoding
fromPlainEncoding (Word32 -> Encoding
C.encodeWord32 Word32
e)

encodeWord64 :: Word64 -> Encoding
encodeWord64 :: Word64 -> Encoding
encodeWord64 Word64
e = Encoding -> Encoding
fromPlainEncoding (Word64 -> Encoding
C.encodeWord64 Word64
e)

encodeInt :: Int -> Encoding
encodeInt :: Int -> Encoding
encodeInt Int
e = Encoding -> Encoding
fromPlainEncoding (Int -> Encoding
C.encodeInt Int
e)

encodeInt8 :: Int8 -> Encoding
encodeInt8 :: Int8 -> Encoding
encodeInt8 Int8
e = Encoding -> Encoding
fromPlainEncoding (Int8 -> Encoding
C.encodeInt8 Int8
e)

encodeInt16 :: Int16 -> Encoding
encodeInt16 :: Int16 -> Encoding
encodeInt16 Int16
e = Encoding -> Encoding
fromPlainEncoding (Int16 -> Encoding
C.encodeInt16 Int16
e)

encodeInt32 :: Int32 -> Encoding
encodeInt32 :: Int32 -> Encoding
encodeInt32 Int32
e = Encoding -> Encoding
fromPlainEncoding (Int32 -> Encoding
C.encodeInt32 Int32
e)

encodeInt64 :: Int64 -> Encoding
encodeInt64 :: Int64 -> Encoding
encodeInt64 Int64
e = Encoding -> Encoding
fromPlainEncoding (Int64 -> Encoding
C.encodeInt64 Int64
e)

encodeInteger :: Integer -> Encoding
encodeInteger :: Integer -> Encoding
encodeInteger Integer
e = Encoding -> Encoding
fromPlainEncoding (Integer -> Encoding
C.encodeInteger Integer
e)

encodeBytes :: ByteString -> Encoding
encodeBytes :: ByteString -> Encoding
encodeBytes ByteString
e = Encoding -> Encoding
fromPlainEncoding (ByteString -> Encoding
C.encodeBytes ByteString
e)

encodeBytesIndef :: Encoding
encodeBytesIndef :: Encoding
encodeBytesIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeBytesIndef

encodeByteArray :: SlicedByteArray -> Encoding
encodeByteArray :: SlicedByteArray -> Encoding
encodeByteArray SlicedByteArray
e = Encoding -> Encoding
fromPlainEncoding (SlicedByteArray -> Encoding
C.encodeByteArray SlicedByteArray
e)

encodeString :: Text -> Encoding
encodeString :: Text -> Encoding
encodeString Text
e = Encoding -> Encoding
fromPlainEncoding (Text -> Encoding
C.encodeString Text
e)

encodeStringIndef :: Encoding
encodeStringIndef :: Encoding
encodeStringIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeStringIndef

encodeUtf8ByteArray :: SlicedByteArray -> Encoding
encodeUtf8ByteArray :: SlicedByteArray -> Encoding
encodeUtf8ByteArray SlicedByteArray
e = Encoding -> Encoding
fromPlainEncoding (SlicedByteArray -> Encoding
C.encodeUtf8ByteArray SlicedByteArray
e)

encodeListLen :: Word -> Encoding
encodeListLen :: Word -> Encoding
encodeListLen Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeListLen Word
e)

encodeListLenIndef :: Encoding
encodeListLenIndef :: Encoding
encodeListLenIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeListLenIndef

encodeMapLen :: Word -> Encoding
encodeMapLen :: Word -> Encoding
encodeMapLen Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeMapLen Word
e)

encodeMapLenIndef :: Encoding
encodeMapLenIndef :: Encoding
encodeMapLenIndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeMapLenIndef

encodeBreak :: Encoding
encodeBreak :: Encoding
encodeBreak = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeBreak

encodeTag :: Word -> Encoding
encodeTag :: Word -> Encoding
encodeTag Word
e = Encoding -> Encoding
fromPlainEncoding (Word -> Encoding
C.encodeTag Word
e)

encodeTag64 :: Word64 -> Encoding
encodeTag64 :: Word64 -> Encoding
encodeTag64 Word64
e = Encoding -> Encoding
fromPlainEncoding (Word64 -> Encoding
C.encodeTag64 Word64
e)

encodeBool :: Bool -> Encoding
encodeBool :: Bool -> Encoding
encodeBool Bool
e = Encoding -> Encoding
fromPlainEncoding (Bool -> Encoding
C.encodeBool Bool
e)

encodeUndef :: Encoding
encodeUndef :: Encoding
encodeUndef = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeUndef

encodeNull :: Encoding
encodeNull :: Encoding
encodeNull = Encoding -> Encoding
fromPlainEncoding Encoding
C.encodeNull

encodeSimple :: Word8 -> Encoding
encodeSimple :: Word8 -> Encoding
encodeSimple Word8
e = Encoding -> Encoding
fromPlainEncoding (Word8 -> Encoding
C.encodeSimple Word8
e)

encodeFloat16 :: Float -> Encoding
encodeFloat16 :: Float -> Encoding
encodeFloat16 Float
e = Encoding -> Encoding
fromPlainEncoding (Float -> Encoding
C.encodeFloat16 Float
e)

encodeFloat :: Float -> Encoding
encodeFloat :: Float -> Encoding
encodeFloat Float
e = Encoding -> Encoding
fromPlainEncoding (Float -> Encoding
C.encodeFloat Float
e)

encodeDouble :: Double -> Encoding
encodeDouble :: Double -> Encoding
encodeDouble Double
e = Encoding -> Encoding
fromPlainEncoding (Double -> Encoding
C.encodeDouble Double
e)

encodePreEncoded :: ByteString -> Encoding
encodePreEncoded :: ByteString -> Encoding
encodePreEncoded ByteString
e = Encoding -> Encoding
fromPlainEncoding (ByteString -> Encoding
C.encodePreEncoded ByteString
e)

encodeTerm :: C.Term -> Encoding
encodeTerm :: Term -> Encoding
encodeTerm = Encoding -> Encoding
fromPlainEncoding (Encoding -> Encoding) -> (Term -> Encoding) -> Term -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Encoding
C.encodeTerm

--------------------------------------------------------------------------------
-- Custom
--------------------------------------------------------------------------------

encodeVersion :: Version -> Encoding
encodeVersion :: Version -> Encoding
encodeVersion = Word64 -> Encoding
encodeWord64 (Word64 -> Encoding) -> (Version -> Word64) -> Version -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Word64
getVersion64

encodeRatioNoTag :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r =
  Word -> Encoding
encodeListLen Word
2
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (Ratio t -> t
forall a. Ratio a -> a
numerator Ratio t
r)
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> t -> Encoding
encodeNumeric (Ratio t -> t
forall a. Ratio a -> a
denominator Ratio t
r)

-- | Encode a rational number with tag 30, as per tag assignment:
-- <https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml>
--
-- <https://peteroupc.github.io/CBOR/rational.html>
encodeRatioWithTag :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag t -> Encoding
encodeNumeric Ratio t
r =
  Word -> Encoding
encodeTag Word
30 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (t -> Encoding) -> Ratio t -> Encoding
forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r

encodeRatio :: (t -> Encoding) -> Ratio t -> Encoding
encodeRatio :: forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatio t -> Encoding
encodeNumeric Ratio t
r =
  Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
    (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
    ((t -> Encoding) -> Ratio t -> Encoding
forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioWithTag t -> Encoding
encodeNumeric Ratio t
r)
    ((t -> Encoding) -> Ratio t -> Encoding
forall t. (t -> Encoding) -> Ratio t -> Encoding
encodeRatioNoTag t -> Encoding
encodeNumeric Ratio t
r)

encodeEnum :: Enum a => a -> Encoding
encodeEnum :: forall a. Enum a => a -> Encoding
encodeEnum = Int -> Encoding
encodeInt (Int -> Encoding) -> (a -> Int) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

encodeWithOrigin :: (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin :: forall a. (a -> Encoding) -> WithOrigin a -> Encoding
encodeWithOrigin a -> Encoding
f = (a -> Encoding) -> Maybe a -> Encoding
forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe a -> Encoding
f (Maybe a -> Encoding)
-> (WithOrigin a -> Maybe a) -> WithOrigin a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOrigin a -> Maybe a
forall t. WithOrigin t -> Maybe t
withOriginToMaybe

--------------------------------------------------------------------------------
-- Containers
--------------------------------------------------------------------------------

encodeMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe :: forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeMaybe a -> Encoding
encodeValue = \case
  Maybe a
Nothing -> Word -> Encoding
encodeListLen Word
0
  Just a
x -> Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeValue a
x

-- | Alternative way to encode a Maybe type.
--
-- /Note/ - this is not the default method for encoding `Maybe`, use `encodeMaybe` instead
encodeNullMaybe :: (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe :: forall a. (a -> Encoding) -> Maybe a -> Encoding
encodeNullMaybe a -> Encoding
encodeValue = \case
  Maybe a
Nothing -> Encoding
encodeNull
  Just a
x -> a -> Encoding
encodeValue a
x

encodeStrictMaybe :: (a -> Encoding) -> StrictMaybe a -> Encoding
encodeStrictMaybe :: forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeStrictMaybe a -> Encoding
encodeValue = \case
  StrictMaybe a
SNothing -> Word -> Encoding
encodeListLen Word
0
  SJust a
x -> Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encodeValue a
x

-- | Alternative way to encode a Maybe type.
--
-- /Note/ - this is not the default method for encoding `StrictMaybe`, use
-- `encodeStrictMaybe` instead
encodeNullStrictMaybe :: (a -> Encoding) -> StrictMaybe a -> Encoding
encodeNullStrictMaybe :: forall a. (a -> Encoding) -> StrictMaybe a -> Encoding
encodeNullStrictMaybe a -> Encoding
encodeValue = \case
  StrictMaybe a
SNothing -> Encoding
encodeNull
  SJust a
x -> a -> Encoding
encodeValue a
x

encodeTuple :: (a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodeTuple :: forall a b.
(a -> Encoding) -> (b -> Encoding) -> (a, b) -> Encoding
encodeTuple 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

-- | Encode any Foldable with indefinite list length encoding
encodeFoldableAsIndefLenList :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList a -> Encoding
encodeValue f a
xs =
  Encoding
encodeListLenIndef Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> (a -> Encoding -> Encoding) -> Encoding -> f a -> Encoding
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x Encoding
r -> a -> Encoding
encodeValue a
x Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
r) Encoding
encodeBreak f a
xs

encodeFoldableAsDefLenList :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList a -> Encoding
encodeValue f a
xs =
  case (a -> (Sum Word, Encoding)) -> f a -> (Sum Word, Encoding)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' (\a
v -> (Sum Word
1, a -> Encoding
encodeValue a
v)) f a
xs of
    (Sum Word
len, Encoding
exactLenEncList) -> Word -> Encoding
encodeListLen Word
len Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
exactLenEncList

-- | Encode any Foldable with the variable list length encoding, which will use indefinite
-- encoding over 23 elements and definite otherwise.
encodeFoldableEncoder :: Foldable f => (a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder :: forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableEncoder a -> Encoding
encoder f a
xs = Int -> Encoding -> Encoding
variableListLenEncoding Int
len Encoding
contents
  where
    (Int
len, Encoding
contents) = ((Int, Encoding) -> a -> (Int, Encoding))
-> (Int, Encoding) -> f a -> (Int, Encoding)
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, Encoding) -> a -> (Int, Encoding)
forall {a}. Num a => (a, Encoding) -> a -> (a, Encoding)
go (Int
0, Encoding
forall a. Monoid a => a
mempty) f a
xs
    go :: (a, Encoding) -> a -> (a, Encoding)
go (!a
l, !Encoding
enc) a
next = (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Encoding
enc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> a -> Encoding
encoder a
next)

-- | Encode a data structure as a Map with the 0-based index for a Key to a value. Uses
-- variable map length encoding, which means an indefinite encoding for maps with over 23
-- elements and definite otherwise.
encodeFoldableMapEncoder ::
  Foldable f =>
  -- | A function that accepts an index of the value in the foldable data strucure, the
  -- actual value and optionally produces the encoding of the value and an index if that
  -- value should be encoded.
  (Word -> a -> Maybe Encoding) ->
  f a ->
  Encoding
encodeFoldableMapEncoder :: forall (f :: * -> *) a.
Foldable f =>
(Word -> a -> Maybe Encoding) -> f a -> Encoding
encodeFoldableMapEncoder Word -> a -> Maybe Encoding
encode f a
xs = Int -> Encoding -> Encoding
variableMapLenEncoding Int
len Encoding
contents
  where
    (Int
len, Word
_, Encoding
contents) = ((Int, Word, Encoding) -> a -> (Int, Word, Encoding))
-> (Int, Word, Encoding) -> f a -> (Int, Word, Encoding)
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl' (Int, Word, Encoding) -> a -> (Int, Word, Encoding)
forall {a}.
Num a =>
(a, Word, Encoding) -> a -> (a, Word, Encoding)
go (Int
0, Word
0, Encoding
forall a. Monoid a => a
mempty) f a
xs
    go :: (a, Word, Encoding) -> a -> (a, Word, Encoding)
go (!a
l, !Word
i, !Encoding
enc) a
next = case Word -> a -> Maybe Encoding
encode Word
i a
next of
      Maybe Encoding
Nothing -> (a
l, Word
i Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc)
      Just Encoding
e -> (a
l a -> a -> a
forall a. Num a => a -> a -> a
+ a
1, Word
i Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
1, Encoding
enc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
e)

--------------------------------------------------------------------------------
-- Map
--------------------------------------------------------------------------------

-- | Encode a Map. Versions variance:
--
-- * [>= 2] - Variable length encoding for Maps larger than 23 key value pairs, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding.
encodeMap ::
  (k -> Encoding) ->
  (v -> Encoding) ->
  Map.Map k v ->
  Encoding
encodeMap :: forall k v.
(k -> Encoding) -> (v -> Encoding) -> Map k v -> Encoding
encodeMap k -> Encoding
encodeKey v -> Encoding
encodeValue Map k v
m =
  let mapEncoding :: Encoding
mapEncoding = (k -> v -> Encoding) -> Map k v -> Encoding
forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.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) Map k v
m
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        (Int -> Encoding -> Encoding
variableMapLenEncoding (Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
m) Encoding
mapEncoding)
        (Int -> Encoding -> Encoding
exactMapLenEncoding (Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
m) Encoding
mapEncoding)
{-# INLINE encodeMap #-}

-- | Mimics `Map` encoder `encodeMap` identically.
encodeVMap ::
  (VMap.Vector kv k, VMap.Vector vv v) =>
  (k -> Encoding) ->
  (v -> Encoding) ->
  VMap.VMap kv vv k v ->
  Encoding
encodeVMap :: forall (kv :: * -> *) k (vv :: * -> *) v.
(Vector kv k, Vector vv v) =>
(k -> Encoding) -> (v -> Encoding) -> VMap kv vv k v -> Encoding
encodeVMap k -> Encoding
encodeKey v -> Encoding
encodeValue VMap kv vv k v
m =
  let mapEncoding :: Encoding
mapEncoding = (k -> v -> Encoding) -> VMap kv 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 kv vv k v
m
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        (Int -> Encoding -> Encoding
variableMapLenEncoding (VMap kv vv k v -> Int
forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size VMap kv vv k v
m) Encoding
mapEncoding)
        (Int -> Encoding -> Encoding
exactMapLenEncoding (VMap kv vv k v -> Int
forall (kv :: * -> *) k (vv :: * -> *) v.
Vector kv k =>
VMap kv vv k v -> Int
VMap.size VMap kv vv k v
m) Encoding
mapEncoding)
{-# INLINE encodeVMap #-}

-- Usage of fromIntegral in `exactMapLenEncoding` is safe, since it is an internal function
-- and is applied to Map's size.
exactMapLenEncoding :: Int -> Encoding -> Encoding
exactMapLenEncoding :: Int -> Encoding -> Encoding
exactMapLenEncoding Int
len Encoding
contents =
  Word -> Encoding
encodeMapLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents
{-# INLINE exactMapLenEncoding #-}

-- | Conditionally use variable length encoding, but only for Maps larger than 23
variableMapLenEncoding :: Int -> Encoding -> Encoding
variableMapLenEncoding :: Int -> Encoding -> Encoding
variableMapLenEncoding Int
len Encoding
contents =
  if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lengthThreshold
    then Int -> Encoding -> Encoding
exactMapLenEncoding Int
len 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
{-# INLINE variableMapLenEncoding #-}

-- | This is the optimal maximum number for encoding exact length. Above that threashold
-- using variable length encoding will result in less bytes on the wire.
lengthThreshold :: Int
lengthThreshold :: Int
lengthThreshold = Int
23

--------------------------------------------------------------------------------
-- Set
--------------------------------------------------------------------------------

-- | Usage of fromIntegral in `exactListLenEncoding` is safe, since it is an internal function
-- and is applied to List's size.
exactListLenEncoding :: Int -> Encoding -> Encoding
exactListLenEncoding :: Int -> Encoding -> Encoding
exactListLenEncoding Int
len Encoding
contents =
  Word -> Encoding
encodeListLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: Word) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
contents
{-# INLINE exactListLenEncoding #-}

-- | Conditionally use variable length encoding for list like structures with length
-- larger than 23, otherwise use exact list length encoding.
variableListLenEncoding ::
  -- | Number of elements in the encoded data structure.
  Int ->
  -- | Encoding for the actual data structure
  Encoding ->
  Encoding
variableListLenEncoding :: Int -> Encoding -> Encoding
variableListLenEncoding Int
len Encoding
contents =
  if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lengthThreshold
    then Int -> Encoding -> Encoding
exactListLenEncoding Int
len 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
{-# INLINE variableListLenEncoding #-}

-- | Encode a Set. Versions variance:
--
-- * [>= 9] - Variable length encoding for Sets larger than 23 elements, otherwise exact
--   length encoding. Prefixes with a special 258 `setTag`.
--
-- * [>= 2] - Variable length encoding for Sets larger than 23 elements, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding. Prefixes with a special 258 `setTag`.
encodeSet :: (a -> Encoding) -> Set.Set a -> Encoding
encodeSet :: forall a. (a -> Encoding) -> Set a -> Encoding
encodeSet a -> Encoding
encodeValue Set a
f =
  let foldableEncoding :: Encoding
foldableEncoding = (a -> Encoding) -> Set a -> Encoding
forall m a. Monoid m => (a -> m) -> Set a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' a -> Encoding
encodeValue Set a
f
      varLenSetEncoding :: Encoding
varLenSetEncoding = Int -> Encoding -> Encoding
variableListLenEncoding (Set a -> Int
forall a. Set a -> Int
Set.size Set a
f) Encoding
foldableEncoding
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
        (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2)
        ( Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
            (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
            (Word -> Encoding
encodeTag Word
setTag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
varLenSetEncoding)
            Encoding
varLenSetEncoding
        )
        (Word -> Encoding
encodeTag Word
setTag Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding -> Encoding
exactListLenEncoding (Set a -> Int
forall a. Set a -> Int
Set.size Set a
f) Encoding
foldableEncoding)
{-# INLINE encodeSet #-}

-- | Encode a list. Versions variance:
--
-- * [>= 2] - Variable length encoding for lists longer than 23 elements, otherwise exact
--   length encoding
--
-- * [< 2] - Variable length encoding
encodeList :: (a -> Encoding) -> [a] -> Encoding
encodeList :: forall a. (a -> Encoding) -> [a] -> Encoding
encodeList a -> Encoding
encodeValue [a]
xs =
  let varLenEncList :: Encoding
varLenEncList = (a -> Encoding) -> [a] -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList a -> Encoding
encodeValue [a]
xs
      -- we don't want to compute the length of the list, unless it is smaller than the
      -- threshold
      encListVer2 :: Encoding
encListVer2 =
        case Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
lengthThreshold [a]
xs of
          [] -> (a -> Encoding) -> [a] -> Encoding
forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsDefLenList a -> Encoding
encodeValue [a]
xs
          [a]
_ -> Encoding
varLenEncList
   in Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) Encoding
encListVer2 Encoding
varLenEncList

-- | Encode a Seq. Variable length encoding for Sequences larger than 23 elements,
--   otherwise exact length encoding
encodeSeq :: (a -> Encoding) -> Seq.Seq a -> Encoding
encodeSeq :: forall a. (a -> Encoding) -> Seq a -> Encoding
encodeSeq a -> Encoding
encodeValue Seq a
f = Int -> Encoding -> Encoding
variableListLenEncoding (Seq a -> Int
forall a. Seq a -> Int
Seq.length Seq a
f) ((a -> Encoding) -> Seq a -> Encoding
forall m a. Monoid m => (a -> m) -> Seq a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' a -> Encoding
encodeValue Seq a
f)
{-# INLINE encodeSeq #-}

encodeStrictSeq :: (a -> Encoding) -> SSeq.StrictSeq a -> Encoding
encodeStrictSeq :: forall a. (a -> Encoding) -> StrictSeq a -> Encoding
encodeStrictSeq a -> Encoding
encodeValue = (a -> Encoding) -> Seq a -> Encoding
forall a. (a -> Encoding) -> Seq a -> Encoding
encodeSeq a -> Encoding
encodeValue (Seq a -> Encoding)
-> (StrictSeq a -> Seq a) -> StrictSeq a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq a -> Seq a
forall a. StrictSeq a -> Seq a
SSeq.fromStrict
{-# INLINE encodeStrictSeq #-}

--------------------------------------------------------------------------------
-- Vector
--------------------------------------------------------------------------------
encodeContainerSkel ::
  (Word -> Encoding) ->
  (container -> Int) ->
  (accumFunc -> Encoding -> container -> Encoding) ->
  accumFunc ->
  container ->
  Encoding
encodeContainerSkel :: forall container accumFunc.
(Word -> Encoding)
-> (container -> Int)
-> (accumFunc -> Encoding -> container -> Encoding)
-> accumFunc
-> container
-> Encoding
encodeContainerSkel Word -> Encoding
encodeLen container -> Int
size accumFunc -> Encoding -> container -> Encoding
foldFunction accumFunc
f container
c =
  Word -> Encoding
encodeLen (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (container -> Int
size container
c)) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> accumFunc -> Encoding -> container -> Encoding
foldFunction accumFunc
f Encoding
forall a. Monoid a => a
mempty container
c
{-# INLINE encodeContainerSkel #-}

-- | Generic encoder for vectors. Its intended use is to allow easy
-- definition of 'EncCBOR' instances for custom vector
encodeVector :: VG.Vector v a => (a -> Encoding) -> v a -> Encoding
encodeVector :: forall (v :: * -> *) a.
Vector v a =>
(a -> Encoding) -> v a -> Encoding
encodeVector a -> Encoding
encodeValue =
  (Word -> Encoding)
-> (v a -> Int)
-> ((a -> Encoding -> Encoding) -> Encoding -> v a -> Encoding)
-> (a -> Encoding -> Encoding)
-> v a
-> Encoding
forall container accumFunc.
(Word -> Encoding)
-> (container -> Int)
-> (accumFunc -> Encoding -> container -> Encoding)
-> accumFunc
-> container
-> Encoding
encodeContainerSkel
    Word -> Encoding
encodeListLen
    v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
VG.length
    (a -> Encoding -> Encoding) -> Encoding -> v a -> Encoding
forall (v :: * -> *) a b.
Vector v a =>
(a -> b -> b) -> b -> v a -> b
VG.foldr
    (\a
a Encoding
b -> a -> Encoding
encodeValue a
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
b)
{-# INLINE encodeVector #-}

--------------------------------------------------------------------------------
-- Time
--------------------------------------------------------------------------------

encodeUTCTime :: UTCTime -> Encoding
encodeUTCTime :: UTCTime -> Encoding
encodeUTCTime (UTCTime Day
day DiffTime
timeOfDay) =
  Word -> Encoding
encodeListLen Word
3
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
encodeInteger Integer
year
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
encodeInt Int
dayOfYear
    Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Integer -> Encoding
encodeInteger Integer
timeOfDayPico
  where
    (Integer
year, Int
dayOfYear) = Day -> (Integer, Int)
toOrdinalDate Day
day
    timeOfDayPico :: Integer
timeOfDayPico = DiffTime -> Integer
diffTimeToPicoseconds DiffTime
timeOfDay

--------------------------------------------------------------------------------
-- Network
--------------------------------------------------------------------------------

ipv4ToBytes :: IPv4 -> BS.ByteString
ipv4ToBytes :: IPv4 -> ByteString
ipv4ToBytes = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (IPv4 -> ByteString) -> IPv4 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (IPv4 -> Put) -> IPv4 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Put
putWord32le (Word32 -> Put) -> (IPv4 -> Word32) -> IPv4 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> Word32
toHostAddress

encodeIPv4 :: IPv4 -> Encoding
encodeIPv4 :: IPv4 -> Encoding
encodeIPv4 = ByteString -> Encoding
encodeBytes (ByteString -> Encoding)
-> (IPv4 -> ByteString) -> IPv4 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> ByteString
ipv4ToBytes

ipv6ToBytes :: IPv6 -> BS.ByteString
ipv6ToBytes :: IPv6 -> ByteString
ipv6ToBytes IPv6
ipv6 = ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString)
-> (Put -> ByteString) -> Put -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  let (Word32
w1, Word32
w2, Word32
w3, Word32
w4) = IPv6 -> (Word32, Word32, Word32, Word32)
toHostAddress6 IPv6
ipv6
  Word32 -> Put
putWord32le Word32
w1
  Word32 -> Put
putWord32le Word32
w2
  Word32 -> Put
putWord32le Word32
w3
  Word32 -> Put
putWord32le Word32
w4

encodeIPv6 :: IPv6 -> Encoding
encodeIPv6 :: IPv6 -> Encoding
encodeIPv6 = ByteString -> Encoding
encodeBytes (ByteString -> Encoding)
-> (IPv6 -> ByteString) -> IPv6 -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> ByteString
ipv6ToBytes