{-# 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
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
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
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))
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
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))
encodeRec :: [(FieldName, Type Void)] -> [(FieldName, Value)] -> B.Builder
encodeRec :: Fields Void -> [(FieldName, Value)] -> Builder
encodeRec [] [(FieldName, Value)]
_ = Builder
forall a. Monoid a => a
mempty
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
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
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"
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
$
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
]
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