{-# 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
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SeqDesc -> [Value] -> Builder
encodeValues (forall k.
(Pretty k, Ord k) =>
Map k (Type k) -> [Type k] -> SeqDesc
SeqDesc 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 = 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]
_ = 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 forall a. Semigroup a => a -> a -> a
<> [Type Void] -> [Value] -> Builder
encodeSeq [Type Void]
ts [Value]
xs
encodeSeq [Type Void]
_ [] = 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 forall a. Ord a => a -> a -> Bool
>= Scientific
0, Right Natural
i <- forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger @Double Scientific
n = Type Void -> Value -> Builder
encodeVal forall a. Type a
NatT (Natural -> Value
NatV Natural
i)
encodeVal Type Void
NatT (NatV Natural
n) = 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 <- forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger @Double Scientific
n = Type Void -> Value -> Builder
encodeVal forall a. Type a
IntT (Integer -> Value
IntV Integer
i)
encodeVal Type Void
IntT (NatV Natural
n) = Type Void -> Value -> Builder
encodeVal forall a. Type a
IntT (Integer -> Value
IntV (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n)) -- NB Subtyping
encodeVal Type Void
IntT (IntV Integer
n) = 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 = forall a. Monoid a => a
mempty
encodeVal Type Void
ReservedT Value
_ = 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 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) =
    forall a. Integral a => a -> Builder
buildLEB128Int (forall a. Vector a -> Int
V.length Vector Value
xs) forall a. Semigroup a => a -> a -> a
<>
    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 (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' = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst Fields Void
fs
encodeVal (VariantT Fields Void
fs) (VariantV FieldName
f Value
x) =
    case forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\(FieldName
f',Type Void
_) -> FieldName
f' forall a. Eq a => a -> a -> Bool
== FieldName
f) Fields Void
fs' of
        Just Int
i | let t :: Type Void
t = forall a b. (a, b) -> b
snd (Fields Void
fs' forall a. [a] -> Int -> a
!! Int
i) ->
            forall a. Integral a => a -> Builder
buildLEB128Int Int
i forall a. Semigroup a => a -> a -> a
<> Type Void -> Value -> Builder
encodeVal Type Void
t Value
x
        Maybe Int
Nothing -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"encodeVal: Variant field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty FieldName
f) forall a. [a] -> [a] -> [a]
++ String
" not found"
  where
    fs' :: Fields Void
fs' = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn 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 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 forall a. Semigroup a => a -> a -> a
<> Int8 -> Builder
B.int8 Int8
1 forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
encodeBytes ByteString
s 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 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
_ = forall a. Void -> a
absurd Void
x
encodeVal Type Void
t Value
v = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Unexpected value at type " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty Type Void
t) forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a ann. Pretty a => a -> Doc ann
pretty Value
v)

encodeBytes :: BS.ByteString -> B.Builder
encodeBytes :: ByteString -> Builder
encodeBytes ByteString
bytes = forall a. Integral a => a -> Builder
buildLEB128Int (ByteString -> Int64
BS.length ByteString
bytes) 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)]
_ = forall a. Monoid a => a
mempty -- NB: Subtyping
encodeRec ((FieldName
f,Type Void
t):Fields Void
fs) [(FieldName, Value)]
vs
    | Just Value
v <- 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 forall a. Semigroup a => a -> a -> a
<> Fields Void -> [(FieldName, Value)] -> Builder
encodeRec Fields Void
fs [(FieldName, Value)]
vs
    | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Missing record field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (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])) = forall a. Monoid a => [a] -> a
mconcat
    [ forall a. LEB128 a => a -> Builder
buildLEB128 Natural
typ_tbl_len
    , Builder
typ_tbl
    , forall a. [a] -> Builder
leb128Len [Type k]
ts
    , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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) = forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type k -> TypTableBuilder k Integer
go [Type k]
ts) () (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 -> TypTableBuilder k Integer
addCon Type k
t TypTableBuilder k Builder
body = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Type k
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Integer
i -> forall (m :: * -> *) a. Monad m => a -> m a
return Integer
i
        Maybe Integer
Nothing -> mdo
            Natural
i <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a, b) -> b
snd
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Type k
t (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i)))
            forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. Enum a => a -> a
succ)
            forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell Builder
b
            Builder
b <- TypTableBuilder k Builder
body
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
i

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

      -- Constructors
      OptT Type k
t' -> Type k -> TypTableBuilder k Builder -> TypTableBuilder k Integer
addCon Type k
t forall a b. (a -> b) -> a -> b
$ do
        Integer
ti <- Type k -> TypTableBuilder k Integer
go Type k
t'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
18) forall a. Semigroup a => a -> a -> a
<> forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti
      VecT Type k
t' -> Type k -> TypTableBuilder k Builder -> TypTableBuilder k Integer
addCon Type k
t forall a b. (a -> b) -> a -> b
$ do
        Integer
ti <- Type k -> TypTableBuilder k Integer
go Type k
t'
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
19) forall a. Semigroup a => a -> a -> a
<> forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti
      RecT Fields k
fs -> Type k -> TypTableBuilder k Builder -> TypTableBuilder k Integer
addCon Type k
t 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 -> TypTableBuilder k Integer
addCon Type k
t 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 -> TypTableBuilder k Integer
addCon Type k
t 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 -> TypTableBuilder k Integer
addCon Type k
t forall a b. (a -> b) -> a -> b
$ do
        [(Text, Integer)]
ms' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Text, MethodType k)]
ms forall a b. (a -> b) -> a -> b
$ \(Text
n, MethodType k
mt) -> do
          Integer
ti <- Type k -> TypTableBuilder k Integer
go (forall a. MethodType a -> Type a
FuncT MethodType k
mt)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Text
n, Integer
ti)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
          [ forall a. SLEB128 a => a -> Builder
buildSLEB128 @Integer (-Integer
23)
          , forall a. [a] -> Builder
leb128Len [(Text, MethodType k)]
ms
          , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(Text
n, Integer
ti) -> Text -> Builder
encodeText Text
n forall a. Semigroup a => a -> a -> a
<> forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti) [(Text, Integer)]
ms'
          ]

      Type k
PrincipalT -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ -Integer
24

      Type k
FutureT    -> forall a. HasCallStack => String -> a
error String
"Cannot encode a future type"

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

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

    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 -> TypTableBuilder k Integer
go Type k
t
        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 <- 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
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat
            [ forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
n
            , forall a. [a] -> Builder
leb128Len [(FieldName, Integer)]
tis
            , forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\(FieldName
f,Integer
ti) -> forall a. LEB128 a => a -> Builder
buildLEB128 (FieldName -> Word32
fieldHash FieldName
f) forall a. Semigroup a => a -> a -> a
<> forall a. SLEB128 a => a -> Builder
buildSLEB128 Integer
ti) forall a b. (a -> b) -> a -> b
$
              forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst [(FieldName, Integer)]
tis -- TODO: Check duplicates maybe?
            ]

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

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