{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Proto3.Wire.Encode
(
MessageBuilder
, reverseMessageBuilder
, vectorMessageBuilder
, messageLength
, toLazyByteString
, unsafeFromLazyByteString
, int32
, int64
, uint32
, uint64
, sint32
, sint64
, fixed32
, fixed64
, sfixed32
, sfixed64
, float
, double
, enum
, bool
, bytes
, string
, text
, byteString
, lazyByteString
, embedded
, packedVarints
, packedVarintsV
, packedBoolsV
, packedFixed32
, packedFixed32V
, packedFixed64
, packedFixed64V
, packedFloats
, packedFloatsV
, packedDoubles
, packedDoublesV
) where
import Data.Bits ( (.|.), shiftL, shiftR, xor )
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Coerce ( coerce )
import Data.Int ( Int32, Int64 )
import qualified Data.Text.Lazy as Text.Lazy
import Data.Vector.Generic ( Vector )
import Data.Word ( Word8, Word32, Word64 )
import GHC.TypeLits ( KnownNat, Nat, type (+) )
import Parameterized.Data.Semigroup ( PNullary, PSemigroup(..),
(&<>) )
import Parameterized.Data.Monoid ( PMEmpty(..) )
import qualified Proto3.Wire.Reverse as RB
import qualified Proto3.Wire.Reverse.Prim as Prim
import Proto3.Wire.Class
import Proto3.Wire.Types
newtype MessageBuilder = MessageBuilder { unMessageBuilder :: RB.BuildR }
deriving (Monoid, Semigroup)
instance Show MessageBuilder where
showsPrec prec builder =
showParen (prec > 10)
(showString "Proto3.Wire.Encode.unsafeFromLazyByteString " . shows bytes')
where
bytes' = toLazyByteString builder
reverseMessageBuilder :: MessageBuilder -> RB.BuildR
reverseMessageBuilder = unMessageBuilder
etaMessageBuilder :: forall a . (a -> MessageBuilder) -> a -> MessageBuilder
etaMessageBuilder = coerce (RB.etaBuildR @a)
vectorMessageBuilder ::
forall v a . Vector v a => (a -> MessageBuilder) -> v a -> MessageBuilder
vectorMessageBuilder = coerce (RB.vectorBuildR @v @a)
messageLength :: MessageBuilder -> Word
messageLength = fromIntegral . fst . RB.runBuildR . unMessageBuilder
toLazyByteString :: MessageBuilder -> BL.ByteString
toLazyByteString = RB.toLazyByteString . unMessageBuilder
unsafeFromLazyByteString :: BL.ByteString -> MessageBuilder
unsafeFromLazyByteString bytes' =
MessageBuilder { unMessageBuilder = RB.lazyByteString bytes' }
newtype MessageBoundedPrim w
= MessageBoundedPrim { unMessageBoundedPrim :: Prim.BoundedPrim w }
type instance PNullary MessageBoundedPrim width = MessageBoundedPrim width
instance (w1 + w2) ~ w3 =>
PSemigroup MessageBoundedPrim w1 w2 w3
where
pmappend = coerce (pmappend @Nat @Prim.BoundedPrim)
{-# INLINE CONLIKE pmappend #-}
instance Prim.AssocPlusNat MessageBoundedPrim u v w
where
assocLPlusNat = \p -> coerce (Prim.assocLPlusNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE assocLPlusNat #-}
assocRPlusNat = \p -> coerce (Prim.assocRPlusNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE assocRPlusNat #-}
instance Prim.CommPlusNat MessageBoundedPrim u v
where
commPlusNat = \p -> coerce (Prim.commPlusNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE commPlusNat #-}
instance PMEmpty MessageBoundedPrim 0
where
pmempty = coerce (pmempty @Nat @Prim.BoundedPrim)
{-# INLINE CONLIKE pmempty #-}
instance Prim.Max u v ~ w =>
Prim.PChoose MessageBoundedPrim u v w
where
pbool = coerce (Prim.pbool @Prim.BoundedPrim)
{-# INLINE CONLIKE pbool #-}
instance Prim.AssocMaxNat MessageBoundedPrim u v w
where
assocLMaxNat = \p -> coerce (Prim.assocLMaxNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE assocLMaxNat #-}
assocRMaxNat = \p -> coerce (Prim.assocRMaxNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE assocRMaxNat #-}
instance Prim.CommMaxNat MessageBoundedPrim u v
where
commMaxNat = \p -> coerce (Prim.commMaxNat @Prim.BoundedPrim p)
{-# INLINE CONLIKE commMaxNat #-}
liftBoundedPrim :: KnownNat w => MessageBoundedPrim w -> MessageBuilder
liftBoundedPrim (MessageBoundedPrim p) = MessageBuilder (Prim.liftBoundedPrim p)
{-# INLINE liftBoundedPrim #-}
base128Varint32 :: Word32 -> MessageBoundedPrim 5
base128Varint32 = MessageBoundedPrim . Prim.word32Base128LEVar
{-# INLINE base128Varint32 #-}
base128Varint64 :: Word64 -> MessageBoundedPrim 10
base128Varint64 = MessageBoundedPrim . Prim.word64Base128LEVar
{-# INLINE base128Varint64 #-}
base128Varint64_inline :: Word64 -> MessageBoundedPrim 10
base128Varint64_inline = MessageBoundedPrim . Prim.word64Base128LEVar_inline
{-# INLINE base128Varint64_inline #-}
wireType :: WireType -> Word8
wireType Varint = 0
wireType Fixed32 = 5
wireType Fixed64 = 1
wireType LengthDelimited = 2
fieldHeader :: FieldNumber -> WireType -> MessageBoundedPrim 10
fieldHeader = \num wt -> base128Varint64_inline
((getFieldNumber num `shiftL` 3) .|. fromIntegral (wireType wt))
{-# INLINE fieldHeader #-}
int32 :: FieldNumber -> Int32 -> MessageBuilder
int32 = \num i -> liftBoundedPrim $
fieldHeader num Varint &<> base128Varint64 (fromIntegral i)
{-# INLINE int32 #-}
int64 :: FieldNumber -> Int64 -> MessageBuilder
int64 = \num i -> liftBoundedPrim $
fieldHeader num Varint &<> base128Varint64 (fromIntegral i)
{-# INLINE int64 #-}
uint32 :: FieldNumber -> Word32 -> MessageBuilder
uint32 = \num i -> liftBoundedPrim $
fieldHeader num Varint &<> base128Varint32 i
{-# INLINE uint32 #-}
uint64 :: FieldNumber -> Word64 -> MessageBuilder
uint64 = \num i -> liftBoundedPrim $
fieldHeader num Varint &<> base128Varint64 i
{-# INLINE uint64 #-}
sint32 :: FieldNumber -> Int32 -> MessageBuilder
sint32 = \num i ->
uint32 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 31)))
{-# INLINE sint32 #-}
sint64 :: FieldNumber -> Int64 -> MessageBuilder
sint64 = \num i ->
uint64 num (fromIntegral ((i `shiftL` 1) `xor` (i `shiftR` 63)))
{-# INLINE sint64 #-}
fixed32 :: FieldNumber -> Word32 -> MessageBuilder
fixed32 = \num i -> liftBoundedPrim $
fieldHeader num Fixed32 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.word32LE i))
{-# INLINE fixed32 #-}
fixed64 :: FieldNumber -> Word64 -> MessageBuilder
fixed64 = \num i -> liftBoundedPrim $
fieldHeader num Fixed64 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.word64LE i))
{-# INLINE fixed64 #-}
sfixed32 :: FieldNumber -> Int32 -> MessageBuilder
sfixed32 = \num i -> liftBoundedPrim $
fieldHeader num Fixed32 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.int32LE i))
{-# INLINE sfixed32 #-}
sfixed64 :: FieldNumber -> Int64 -> MessageBuilder
sfixed64 = \num i -> liftBoundedPrim $
fieldHeader num Fixed64 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.int64LE i))
{-# INLINE sfixed64 #-}
float :: FieldNumber -> Float -> MessageBuilder
float = \num f -> liftBoundedPrim $
fieldHeader num Fixed32 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.floatLE f))
{-# INLINE float #-}
double :: FieldNumber -> Double -> MessageBuilder
double = \num d -> liftBoundedPrim $
fieldHeader num Fixed64 &<>
MessageBoundedPrim (Prim.liftFixedPrim (Prim.doubleLE d))
{-# INLINE double #-}
enum :: ProtoEnum e => FieldNumber -> e -> MessageBuilder
enum = \num e -> liftBoundedPrim $
fieldHeader num Varint &<>
base128Varint32 (fromIntegral @Int32 @Word32 (fromProtoEnum e))
{-# INLINE enum #-}
bool :: FieldNumber -> Bool -> MessageBuilder
bool = \num b -> liftBoundedPrim $
fieldHeader num Varint &<>
MessageBoundedPrim
(Prim.liftFixedPrim (Prim.word8 (fromIntegral (fromEnum b))))
{-# INLINE bool #-}
bytes :: FieldNumber -> RB.BuildR -> MessageBuilder
bytes num = embedded num . MessageBuilder
{-# INLINE bytes #-}
string :: FieldNumber -> String -> MessageBuilder
string num = embedded num . MessageBuilder . RB.stringUtf8
{-# INLINE string #-}
text :: FieldNumber -> Text.Lazy.Text -> MessageBuilder
text num = embedded num . MessageBuilder . RB.lazyTextUtf8
{-# INLINE text #-}
byteString :: FieldNumber -> B.ByteString -> MessageBuilder
byteString num = embedded num . MessageBuilder . RB.byteString
{-# INLINE byteString #-}
lazyByteString :: FieldNumber -> BL.ByteString -> MessageBuilder
lazyByteString num = embedded num . MessageBuilder . RB.lazyByteString
{-# INLINE lazyByteString #-}
packedVarints :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder
packedVarints num =
etaMessageBuilder
(embedded num . foldMap (liftBoundedPrim . base128Varint64))
{-# INLINE packedVarints #-}
packedVarintsV ::
Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder
packedVarintsV f num =
embedded num . vectorMessageBuilder (liftBoundedPrim . base128Varint64 . f)
{-# INLINE packedVarintsV #-}
packedBoolsV ::
Vector v a => (a -> Bool) -> FieldNumber -> v a -> MessageBuilder
packedBoolsV f num =
embedded num . MessageBuilder . Prim.vectorFixedPrim op
where
op = Prim.word8 . fromIntegral . fromEnum . f
{-# INLINE packedBoolsV #-}
packedFixed32 :: Foldable f => FieldNumber -> f Word32 -> MessageBuilder
packedFixed32 num =
etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word32LE))
{-# INLINE packedFixed32 #-}
packedFixed32V ::
Vector v a => (a -> Word32) -> FieldNumber -> v a -> MessageBuilder
packedFixed32V f num =
embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word32LE . f)
{-# INLINE packedFixed32V #-}
packedFixed64 :: Foldable f => FieldNumber -> f Word64 -> MessageBuilder
packedFixed64 num =
etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.word64LE))
{-# INLINE packedFixed64 #-}
packedFixed64V ::
Vector v a => (a -> Word64) -> FieldNumber -> v a -> MessageBuilder
packedFixed64V f num =
embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.word64LE . f)
{-# INLINE packedFixed64V #-}
packedFloats :: Foldable f => FieldNumber -> f Float -> MessageBuilder
packedFloats num =
etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.floatLE))
{-# INLINE packedFloats #-}
packedFloatsV ::
Vector v a => (a -> Float) -> FieldNumber -> v a -> MessageBuilder
packedFloatsV f num =
embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.floatLE . f)
{-# INLINE packedFloatsV #-}
packedDoubles :: Foldable f => FieldNumber -> f Double -> MessageBuilder
packedDoubles num =
etaMessageBuilder (embedded num . foldMap (MessageBuilder . RB.doubleLE))
{-# INLINE packedDoubles #-}
packedDoublesV ::
Vector v a => (a -> Double) -> FieldNumber -> v a -> MessageBuilder
packedDoublesV f num =
embedded num . MessageBuilder . Prim.vectorFixedPrim (Prim.doubleLE . f)
{-# INLINE packedDoublesV #-}
embedded :: FieldNumber -> MessageBuilder -> MessageBuilder
embedded = \num (MessageBuilder bb) ->
MessageBuilder (RB.withLengthOf (Prim.liftBoundedPrim . prefix num) bb)
where
prefix num len =
unMessageBoundedPrim (fieldHeader num LengthDelimited) &<>
Prim.wordBase128LEVar (fromIntegral @Int @Word len)
{-# INLINE embedded #-}