{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Data.ProtocolBuffers.Encode
  ( Encode(..)
  , encodeMessage
  , encodeLengthPrefixedMessage
  , GEncode
  ) where

import Data.Foldable
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Proxy
import Data.Binary.Builder.Sized
import Data.Monoid

import GHC.Generics
import GHC.TypeLits

import Data.ProtocolBuffers.Types
import Data.ProtocolBuffers.Wire

-- |
-- Encode a Protocol Buffers message.
encodeMessage :: Encode a => a -> Builder
encodeMessage :: a -> Builder
encodeMessage = a -> Builder
forall a. Encode a => a -> Builder
encode

-- |
-- Encode a Protocol Buffers message prefixed with a varint encoded 32-bit integer describing its length.
encodeLengthPrefixedMessage :: Encode a => a -> Builder
{-# INLINE encodeLengthPrefixedMessage #-}
encodeLengthPrefixedMessage :: a -> Builder
encodeLengthPrefixedMessage a
msg = (Int -> Builder
forall a. (Integral a, Bits a) => a -> Builder
putVarUInt (Int -> Builder) -> Int -> Builder
forall a b. (a -> b) -> a -> b
$ Builder -> Int
size Builder
msg') Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
msg'
  where
    msg' :: Builder
msg' = a -> Builder
forall a. Encode a => a -> Builder
encodeMessage a
msg

class Encode (a :: *) where
  encode :: a -> Builder
  default encode :: (Generic a, GEncode (Rep a)) => a -> Builder
  encode = Rep a Any -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode (Rep a Any -> Builder) -> (a -> Rep a Any) -> a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

-- | Untyped message encoding
instance Encode (HashMap Tag [WireField]) where
  encode :: HashMap Tag [WireField] -> Builder
encode = ((Tag, [WireField]) -> Builder) -> [(Tag, [WireField])] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Tag, [WireField]) -> Builder
step ([(Tag, [WireField])] -> Builder)
-> (HashMap Tag [WireField] -> [(Tag, [WireField])])
-> HashMap Tag [WireField]
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap Tag [WireField] -> [(Tag, [WireField])]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList where
    step :: (Tag, [WireField]) -> Builder
step = (Tag -> [WireField] -> Builder) -> (Tag, [WireField]) -> Builder
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((WireField -> Builder) -> [WireField] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((WireField -> Builder) -> [WireField] -> Builder)
-> (Tag -> WireField -> Builder) -> Tag -> [WireField] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tag -> WireField -> Builder
forall a. EncodeWire a => Tag -> a -> Builder
encodeWire)

class GEncode (f :: * -> *) where
  gencode :: f a -> Builder

instance GEncode a => GEncode (M1 i c a) where
  gencode :: M1 i c a a -> Builder
gencode = a a -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode (a a -> Builder) -> (M1 i c a a -> a a) -> M1 i c a a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (GEncode a, GEncode b) => GEncode (a :*: b) where
  gencode :: (:*:) a b a -> Builder
gencode (a a
x :*: b a
y) = a a -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode a a
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> b a -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode b a
y

instance (GEncode a, GEncode b) => GEncode (a :+: b) where
  gencode :: (:+:) a b a -> Builder
gencode (L1 a a
x) = a a -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode a a
x
  gencode (R1 b a
y) = b a -> Builder
forall (f :: * -> *) a. GEncode f => f a -> Builder
gencode b a
y

instance (EncodeWire a, KnownNat n, Foldable f) => GEncode (K1 i (Field n (f a))) where
  gencode :: K1 i (Field n (f a)) a -> Builder
gencode = (a -> Builder) -> f a -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Tag -> a -> Builder
forall a. EncodeWire a => Tag -> a -> Builder
encodeWire Tag
tag) (f a -> Builder)
-> (K1 i (Field n (f a)) a -> f a)
-> K1 i (Field n (f a)) a
-> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field n (f a) -> f a
forall (n :: Nat) a. Field n a -> a
runField (Field n (f a) -> f a)
-> (K1 i (Field n (f a)) a -> Field n (f a))
-> K1 i (Field n (f a)) a
-> f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i (Field n (f a)) a -> Field n (f a)
forall i c k (p :: k). K1 i c p -> c
unK1 where
    tag :: Tag
tag = Integer -> Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Tag) -> Integer -> Tag
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n)

instance GEncode U1 where
  gencode :: U1 a -> Builder
gencode U1 a
_ = Builder
empty