{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RecursiveDo #-}

module Codec.Candid.Encode (encodeValues, encodeDynValues) where

import Numeric.Natural
import qualified Data.Vector as V
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Builder as B
import qualified Data.Map as M
import Data.Scientific
import Control.Monad
import Control.Monad.State.Lazy
import Control.Monad.RWS.Lazy
import Data.Bifunctor
import Data.List
import Data.Void
import Data.Serialize.LEB128
import Prettyprinter

import Codec.Candid.Data
import Codec.Candid.TypTable
import Codec.Candid.Types
import Codec.Candid.FieldName
import Codec.Candid.Infer


-- | Encodes a Candid value given in the dynamic 'Value' form, at inferred type.
--
-- This may fail if the values have inconsistent types. It does not use the
-- @reserved@ supertype (unless explicitly told to).
--
-- Not all possible values are encodable this way. For example, all function
-- references will be encoded at type @() - ()@.
encodeDynValues :: [Value] -> Either String B.Builder
encodeDynValues :: [Value] -> Either String Builder
encodeDynValues [Value]
vs = do
    [Type Void]
ts <- [Value] -> Either String [Type Void]
inferTypes [Value]
vs
    Builder -> Either String Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> Either String Builder)
-> Builder -> Either String Builder
forall a b. (a -> b) -> a -> b
$ SeqDesc -> [Value] -> Builder
encodeValues (Map Void (Type Void) -> [Type Void] -> SeqDesc
forall k.
(Pretty k, Ord k) =>
Map k (Type k) -> [Type k] -> SeqDesc
SeqDesc Map Void (Type Void)
forall a. Monoid a => a
mempty [Type Void]
ts) [Value]
vs

-- | Encodes a Candid value given in the dynamic 'Value' form, at given type.
--
-- This fails if the values do not match the given type.
encodeValues :: SeqDesc -> [Value] -> B.Builder
encodeValues :: SeqDesc -> [Value] -> Builder
encodeValues SeqDesc
t [Value]
vs = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ String -> Builder
B.stringUtf8 String
"DIDL"
    , SeqDesc -> Builder
typTable SeqDesc
t
    , [Type Void] -> [Value] -> Builder
encodeSeq (SeqDesc -> [Type Void]
tieKnot SeqDesc
t) [Value]
vs
    ]

encodeSeq :: [Type Void] -> [Value] -> B.Builder
encodeSeq :: [Type Void] -> [Value] -> Builder
encodeSeq [] [Value]
_ = Builder
forall a. Monoid a => a
mempty -- NB: Subtyping
encodeSeq (Type Void
t:[Type Void]
ts) (Value
x:[Value]
xs) = Type Void -> Value -> Builder
encodeVal Type Void
t Value
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Type Void] -> [Value] -> Builder
encodeSeq [Type Void]
ts [Value]
xs
encodeSeq [Type Void]
_ [] = String -> Builder
forall a. HasCallStack => String -> a
error String
"encodeSeq: Not enough values"

encodeVal :: Type Void -> Value -> B.Builder
encodeVal :: Type Void -> Value -> Builder
encodeVal Type Void
BoolT (BoolV Bool
False) = Word8 -> Builder
B.word8 Word8
0
encodeVal Type Void
BoolT (BoolV Bool
True) = Word8 -> Builder
B.word8 Word8
1
encodeVal Type Void
NatT (NumV Scientific
n) | Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
0, Right Natural
i <- Scientific -> Either Double Natural
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger @Double Scientific
n = Type Void -> Value -> Builder
encodeVal Type Void
forall a. Type a
NatT (Natural -> Value
NatV Natural
i)
encodeVal Type Void
NatT (NatV Natural
n) = Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 Natural
n
encodeVal Type Void
Nat8T (Nat8V Word8
n) = Word8 -> Builder
B.word8 Word8
n
encodeVal Type Void
Nat16T (Nat16V Word16
n) = Word16 -> Builder
B.word16LE Word16
n
encodeVal Type Void
Nat32T (Nat32V Word32
n) = Word32 -> Builder
B.word32LE Word32
n
encodeVal Type Void
Nat64T (Nat64V Word64
n) = Word64 -> Builder
B.word64LE Word64
n
encodeVal Type Void
IntT (NumV Scientific
n) | Right Integer
i <- Scientific -> Either Double Integer
forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger @Double Scientific
n = Type Void -> Value -> Builder
encodeVal Type Void
forall a. Type a
IntT (Integer -> Value
IntV Integer
i)
encodeVal Type Void
IntT (NatV Natural
n) = Type Void -> Value -> Builder
encodeVal Type Void
forall a. Type a
IntT (Integer -> Value
IntV (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n)) -- NB Subtyping
encodeVal Type Void
IntT (IntV Integer
n) = Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
n
encodeVal Type Void
Int8T (Int8V Int8
n) = Int8 -> Builder
B.int8 Int8
n
encodeVal Type Void
Int16T (Int16V Int16
n) = Int16 -> Builder
B.int16LE Int16
n
encodeVal Type Void
Int32T (Int32V Int32
n) = Int32 -> Builder
B.int32LE Int32
n
encodeVal Type Void
Int64T (Int64V Int64
n) = Int64 -> Builder
B.int64LE Int64
n
encodeVal Type Void
Float32T (Float32V Float
n) = Float -> Builder
B.floatLE Float
n
encodeVal Type Void
Float64T (Float64V Double
n) = Double -> Builder
B.doubleLE Double
n
encodeVal Type Void
TextT (TextV Text
t) = Text -> Builder
encodeText Text
t
encodeVal Type Void
NullT Value
NullV = Builder
forall a. Monoid a => a
mempty
encodeVal Type Void
ReservedT Value
_ = Builder
forall a. Monoid a => a
mempty -- NB Subtyping
encodeVal (OptT Type Void
_) (OptV Maybe Value
Nothing) = Word8 -> Builder
B.word8 Word8
0
encodeVal (OptT Type Void
t) (OptV (Just Value
x)) = Word8 -> Builder
B.word8 Word8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Type Void -> Value -> Builder
encodeVal Type Void
t Value
x
encodeVal (VecT Type Void
t) (VecV Vector Value
xs) =
    Int -> Builder
forall a. Integral a => a -> Builder
buildLEB128Int (Vector Value -> Int
forall a. Vector a -> Int
V.length Vector Value
xs) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    (Value -> Builder) -> Vector Value -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Type Void -> Value -> Builder
encodeVal Type Void
t) Vector Value
xs
encodeVal (RecT Fields Void
fs) (TupV [Value]
vs) = Type Void -> Value -> Builder
encodeVal (Fields Void -> Type Void
forall a. Fields a -> Type a
RecT Fields Void
fs) ([Value] -> Value
tupV [Value]
vs)
encodeVal (RecT Fields Void
fs) (RecV [(FieldName, Value)]
vs) = Fields Void -> [(FieldName, Value)] -> Builder
encodeRec Fields Void
fs' [(FieldName, Value)]
vs
  where
    fs' :: Fields Void
fs' = ((FieldName, Type Void) -> FieldName) -> Fields Void -> Fields Void
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Type Void) -> FieldName
forall a b. (a, b) -> a
fst Fields Void
fs
encodeVal (VariantT Fields Void
fs) (VariantV FieldName
f Value
x) =
    case ((FieldName, Type Void) -> Bool) -> Fields Void -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(FieldName
f',Type Void
_) -> FieldName
f' FieldName -> FieldName -> Bool
forall a. Eq a => a -> a -> Bool
== FieldName
f) Fields Void
fs' of
        Just Int
i | let t :: Type Void
t = (FieldName, Type Void) -> Type Void
forall a b. (a, b) -> b
snd (Fields Void
fs' Fields Void -> Int -> (FieldName, Type Void)
forall a. [a] -> Int -> a
!! Int
i) ->
            Int -> Builder
forall a. Integral a => a -> Builder
buildLEB128Int Int
i Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Type Void -> Value -> Builder
encodeVal Type Void
t Value
x
        Maybe Int
Nothing -> String -> Builder
forall a. HasCallStack => String -> a
error (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"encodeVal: Variant field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (FieldName -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty FieldName
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not found"
  where
    fs' :: Fields Void
fs' = ((FieldName, Type Void) -> FieldName) -> Fields Void -> Fields Void
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Type Void) -> FieldName
forall a b. (a, b) -> a
fst Fields Void
fs
encodeVal (ServiceT [(Text, MethodType Void)]
_) (ServiceV (Principal ByteString
s))
    = Int8 -> Builder
B.int8 Int8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
encodeBytes ByteString
s
encodeVal (FuncT MethodType Void
_) (FuncV (Principal ByteString
s) Text
n)
    = Int8 -> Builder
B.int8 Int8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int8 -> Builder
B.int8 Int8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
encodeBytes ByteString
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
encodeText Text
n
encodeVal Type Void
PrincipalT (PrincipalV (Principal ByteString
s))
    = Int8 -> Builder
B.int8 Int8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
encodeBytes ByteString
s
encodeVal Type Void
BlobT (BlobV ByteString
b) = ByteString -> Builder
encodeBytes ByteString
b
encodeVal (VecT Type Void
Nat8T) (BlobV ByteString
b) = ByteString -> Builder
encodeBytes ByteString
b
encodeVal (RefT Void
x) Value
_ = Void -> Builder
forall a. Void -> a
absurd Void
x
encodeVal Type Void
t Value
v = String -> Builder
forall a. HasCallStack => String -> a
error (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"Unexpected value at type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (Type Void -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Type Void
t) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (Value -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty Value
v)

encodeBytes :: BS.ByteString -> B.Builder
encodeBytes :: ByteString -> Builder
encodeBytes ByteString
bytes = Int64 -> Builder
forall a. Integral a => a -> Builder
buildLEB128Int (ByteString -> Int64
BS.length ByteString
bytes) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
B.lazyByteString ByteString
bytes

encodeText :: T.Text -> B.Builder
encodeText :: Text -> Builder
encodeText Text
t = ByteString -> Builder
encodeBytes (ByteString -> ByteString
BS.fromStrict (Text -> ByteString
T.encodeUtf8 Text
t))

-- Encodes the fields in order specified by the type
encodeRec :: [(FieldName, Type Void)] -> [(FieldName, Value)] -> B.Builder
encodeRec :: Fields Void -> [(FieldName, Value)] -> Builder
encodeRec [] [(FieldName, Value)]
_ = Builder
forall a. Monoid a => a
mempty -- NB: Subtyping
encodeRec ((FieldName
f,Type Void
t):Fields Void
fs) [(FieldName, Value)]
vs
    | Just Value
v <- FieldName -> [(FieldName, Value)] -> Maybe Value
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FieldName
f [(FieldName, Value)]
vs = Type Void -> Value -> Builder
encodeVal Type Void
t Value
v Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Fields Void -> [(FieldName, Value)] -> Builder
encodeRec Fields Void
fs [(FieldName, Value)]
vs
    | Bool
otherwise = String -> Builder
forall a. HasCallStack => String -> a
error (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"Missing record field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc Any -> String
forall a. Show a => a -> String
show (FieldName -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty FieldName
f)

type TypTableBuilder k = RWS () B.Builder (M.Map (Type k) Integer, Natural)

typTable :: SeqDesc -> B.Builder
typTable :: SeqDesc -> Builder
typTable (SeqDesc Map k (Type k)
m ([Type k]
ts :: [Type k])) = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 Natural
typ_tbl_len
    , Builder
typ_tbl
    , [Type k] -> Builder
forall a. [a] -> Builder
leb128Len [Type k]
ts
    , (Integer -> Builder) -> [Integer] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 [Integer]
typ_idxs
    ]
  where
    ([Integer]
typ_idxs, (Map (Type k) Integer
_, Natural
typ_tbl_len), Builder
typ_tbl) = RWS () Builder (Map (Type k) Integer, Natural) [Integer]
-> ()
-> (Map (Type k) Integer, Natural)
-> ([Integer], (Map (Type k) Integer, Natural), Builder)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS ((Type k
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> [Type k]
-> RWS () Builder (Map (Type k) Integer, Natural) [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go [Type k]
ts) () (Map (Type k) Integer
forall k a. Map k a
M.empty, Natural
0)

    addCon :: Type k -> TypTableBuilder k B.Builder -> TypTableBuilder k Integer
    addCon :: Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t TypTableBuilder k Builder
body = ((Map (Type k) Integer, Natural) -> Maybe Integer)
-> RWST
     () Builder (Map (Type k) Integer, Natural) Identity (Maybe Integer)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Type k -> Map (Type k) Integer -> Maybe Integer
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type k
t (Map (Type k) Integer -> Maybe Integer)
-> ((Map (Type k) Integer, Natural) -> Map (Type k) Integer)
-> (Map (Type k) Integer, Natural)
-> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Type k) Integer, Natural) -> Map (Type k) Integer
forall a b. (a, b) -> a
fst) RWST
  () Builder (Map (Type k) Integer, Natural) Identity (Maybe Integer)
-> (Maybe Integer
    -> RWST
         () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Integer
i -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
        Maybe Integer
Nothing -> mdo
            Natural
i <- ((Map (Type k) Integer, Natural) -> Natural)
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Natural
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map (Type k) Integer, Natural) -> Natural
forall a b. (a, b) -> b
snd
            ((Map (Type k) Integer, Natural)
 -> (Map (Type k) Integer, Natural))
-> RWST () Builder (Map (Type k) Integer, Natural) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Map (Type k) Integer -> Map (Type k) Integer)
-> (Map (Type k) Integer, Natural)
-> (Map (Type k) Integer, Natural)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type k -> Integer -> Map (Type k) Integer -> Map (Type k) Integer
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Type k
t (Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i)))
            ((Map (Type k) Integer, Natural)
 -> (Map (Type k) Integer, Natural))
-> RWST () Builder (Map (Type k) Integer, Natural) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Natural -> Natural)
-> (Map (Type k) Integer, Natural)
-> (Map (Type k) Integer, Natural)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Natural -> Natural
forall a. Enum a => a -> a
succ)
            Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Builder
b
            Builder
b <- TypTableBuilder k Builder
body
            Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i

    go :: Type k -> TypTableBuilder k Integer
    go :: Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go Type k
t = case Type k
t of
      Type k
NullT     -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
1
      Type k
BoolT     -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
2
      Type k
NatT      -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
3
      Type k
IntT      -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
4
      Type k
Nat8T     -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
5
      Type k
Nat16T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
6
      Type k
Nat32T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
7
      Type k
Nat64T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
8
      Type k
Int8T     -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
9
      Type k
Int16T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
10
      Type k
Int32T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
11
      Type k
Int64T    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
12
      Type k
Float32T  -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
13
      Type k
Float64T  -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
14
      Type k
TextT     -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
15
      Type k
ReservedT -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
16
      Type k
EmptyT    -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
17

      -- Constructors
      OptT Type k
t' -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ do
        Integer
ti <- Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go Type k
t'
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
18) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti
      VecT Type k
t' -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ do
        Integer
ti <- Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go Type k
t'
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
19) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti
      RecT Fields k
fs -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Fields k -> TypTableBuilder k Builder
recordLike (-Integer
20) Fields k
fs
      VariantT Fields k
fs -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ Integer -> Fields k -> TypTableBuilder k Builder
recordLike (-Integer
21) Fields k
fs

      -- References
      FuncT MethodType k
mt -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ MethodType k -> TypTableBuilder k Builder
goMethod MethodType k
mt

      ServiceT [(Text, MethodType k)]
ms -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ do
        [(Text, Integer)]
ms' <- [(Text, MethodType k)]
-> ((Text, MethodType k)
    -> RWST
         ()
         Builder
         (Map (Type k) Integer, Natural)
         Identity
         (Text, Integer))
-> RWST
     ()
     Builder
     (Map (Type k) Integer, Natural)
     Identity
     [(Text, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, MethodType k)]
ms (((Text, MethodType k)
  -> RWST
       ()
       Builder
       (Map (Type k) Integer, Natural)
       Identity
       (Text, Integer))
 -> RWST
      ()
      Builder
      (Map (Type k) Integer, Natural)
      Identity
      [(Text, Integer)])
-> ((Text, MethodType k)
    -> RWST
         ()
         Builder
         (Map (Type k) Integer, Natural)
         Identity
         (Text, Integer))
-> RWST
     ()
     Builder
     (Map (Type k) Integer, Natural)
     Identity
     [(Text, Integer)]
forall a b. (a -> b) -> a -> b
$ \(Text
n, MethodType k
mt) -> do
          Integer
ti <- Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go (MethodType k -> Type k
forall a. MethodType a -> Type a
FuncT MethodType k
mt)
          (Text, Integer)
-> RWST
     () Builder (Map (Type k) Integer, Natural) Identity (Text, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
n, Integer
ti)
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
23)
          , [(Text, MethodType k)] -> Builder
forall a. [a] -> Builder
leb128Len [(Text, MethodType k)]
ms
          , ((Text, Integer) -> Builder) -> [(Text, Integer)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Text
n, Integer
ti) -> Text -> Builder
encodeText Text
n Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti) [(Text, Integer)]
ms'
          ]

      Type k
PrincipalT -> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> Integer
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$ -Integer
24

      Type k
FutureT    -> String
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a. HasCallStack => String -> a
error String
"Cannot encode a future type"

      -- Short-hands
      Type k
BlobT -> Type k
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
addCon Type k
t (TypTableBuilder k Builder
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> TypTableBuilder k Builder
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
forall a b. (a -> b) -> a -> b
$
        -- blob = vec nat8
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
19) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
5)

      RefT k
t -> Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go (Map k (Type k)
m Map k (Type k) -> k -> Type k
forall k a. Ord k => Map k a -> k -> a
M.! k
t)

    goMethod :: MethodType k -> TypTableBuilder k Builder
goMethod (MethodType [Type k]
as [Type k]
bs Bool
q Bool
cq Bool
o) = do
        [Integer]
ais <- (Type k
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> [Type k]
-> RWS () Builder (Map (Type k) Integer, Natural) [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go [Type k]
as
        [Integer]
bis <- (Type k
 -> RWST
      () Builder (Map (Type k) Integer, Natural) Identity Integer)
-> [Type k]
-> RWS () Builder (Map (Type k) Integer, Natural) [Integer]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go [Type k]
bs
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
          [ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
22)
          , [Integer] -> Builder
forall a. [a] -> Builder
leb128Len [Integer]
ais
          , (Integer -> Builder) -> [Integer] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 [Integer]
ais
          , [Integer] -> Builder
forall a. [a] -> Builder
leb128Len [Integer]
bis
          , (Integer -> Builder) -> [Integer] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 [Integer]
bis
          , [Builder] -> Builder
forall a. [a] -> Builder
leb128Len [Builder]
anns
          , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [Builder]
anns
          ]
      where
        anns :: [Builder]
anns = [Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 @Natural Natural
1 | Bool
q] [Builder] -> [Builder] -> [Builder]
forall a. [a] -> [a] -> [a]
++
               [Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 @Natural Natural
2 | Bool
o] [Builder] -> [Builder] -> [Builder]
forall a. [a] -> [a] -> [a]
++
               [Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 @Natural Natural
3 | Bool
cq]

    goField :: (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer)
    goField :: (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer)
goField (FieldName
fn, Type k
t) = do
        Integer
ti <- Type k
-> RWST () Builder (Map (Type k) Integer, Natural) Identity Integer
go Type k
t
        (FieldName, Integer) -> TypTableBuilder k (FieldName, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldName
fn, Integer
ti)

    recordLike :: Integer -> Fields k -> TypTableBuilder k B.Builder
    recordLike :: Integer -> Fields k -> TypTableBuilder k Builder
recordLike Integer
n Fields k
fs = do
        [(FieldName, Integer)]
tis <- ((FieldName, Type k) -> TypTableBuilder k (FieldName, Integer))
-> Fields k
-> RWST
     ()
     Builder
     (Map (Type k) Integer, Natural)
     Identity
     [(FieldName, Integer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (FieldName, Type k) -> TypTableBuilder k (FieldName, Integer)
goField Fields k
fs
        Builder -> TypTableBuilder k Builder
forall (m :: * -> *) a. Monad m => a -> m a
return (Builder -> TypTableBuilder k Builder)
-> Builder -> TypTableBuilder k Builder
forall a b. (a -> b) -> a -> b
$ [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
            [ Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
n
            , [(FieldName, Integer)] -> Builder
forall a. [a] -> Builder
leb128Len [(FieldName, Integer)]
tis
            , ((FieldName, Integer) -> Builder)
-> [(FieldName, Integer)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(FieldName
f,Integer
ti) -> Word32 -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 (FieldName -> Word32
fieldHash FieldName
f) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Integer -> Builder
forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti) ([(FieldName, Integer)] -> Builder)
-> [(FieldName, Integer)] -> Builder
forall a b. (a -> b) -> a -> b
$
              ((FieldName, Integer) -> FieldName)
-> [(FieldName, Integer)] -> [(FieldName, Integer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FieldName, Integer) -> FieldName
forall a b. (a, b) -> a
fst [(FieldName, Integer)]
tis -- TODO: Check duplicates maybe?
            ]

buildLEB128Int :: Integral a => a -> B.Builder
buildLEB128Int :: a -> Builder
buildLEB128Int = LEB128 Natural => Natural -> Builder
forall a. LEB128 a => a -> Builder
buildLEB128 @Natural (Natural -> Builder) -> (a -> Natural) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral

leb128Len :: [a] -> B.Builder
leb128Len :: [a] -> Builder
leb128Len = Int -> Builder
forall a. Integral a => a -> Builder
buildLEB128Int (Int -> Builder) -> ([a] -> Int) -> [a] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length