{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}

module Dahdit.Generic
  ( ViaGeneric (..)
  , ViaStaticGeneric (..)
  )
where

import Dahdit.Binary (Binary (..))
import Dahdit.Free (Get, Put)
import Dahdit.Funs (putStaticHint)
import Dahdit.Nums (Word16LE, Word32LE)
import Dahdit.Proxy (proxyForRepF)
import Dahdit.Sizes (ByteCount, StaticByteSized (..))
import Data.Bits (Bits (..))
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Word (Word8)
import GHC.Generics (C1, Generic (..), K1 (..), M1 (..), U1 (..), (:*:) (..), (:+:) (..))
import GHC.TypeLits (KnownNat, Nat, natVal, type (+))

-- | Use: deriving (Binary) via (ViaGeneric Foo)
newtype ViaGeneric a = ViaGeneric {forall a. ViaGeneric a -> a
unViaGeneric :: a}

instance (Generic t, GByteSized (Rep t), GBinary (Rep t)) => Binary (ViaGeneric t) where
  byteSize :: ViaGeneric t -> ByteCount
byteSize = Rep t Any -> ByteCount
forall a. Rep t a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize (Rep t Any -> ByteCount)
-> (ViaGeneric t -> Rep t Any) -> ViaGeneric t -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall x. t -> Rep t x
forall a x. Generic a => a -> Rep a x
from (t -> Rep t Any)
-> (ViaGeneric t -> t) -> ViaGeneric t -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViaGeneric t -> t
forall a. ViaGeneric a -> a
unViaGeneric
  get :: Get (ViaGeneric t)
get = (Rep t Any -> ViaGeneric t)
-> Get (Rep t Any) -> Get (ViaGeneric t)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> ViaGeneric t
forall a. a -> ViaGeneric a
ViaGeneric (t -> ViaGeneric t)
-> (Rep t Any -> t) -> Rep t Any -> ViaGeneric t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> t
forall a x. Generic a => Rep a x -> a
forall x. Rep t x -> t
to) Get (Rep t Any)
forall a. Get (Rep t a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget
  put :: ViaGeneric t -> Put
put = Rep t Any -> Put
forall a. Rep t a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput (Rep t Any -> Put)
-> (ViaGeneric t -> Rep t Any) -> ViaGeneric t -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall x. t -> Rep t x
forall a x. Generic a => a -> Rep a x
from (t -> Rep t Any)
-> (ViaGeneric t -> t) -> ViaGeneric t -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViaGeneric t -> t
forall a. ViaGeneric a -> a
unViaGeneric

-- | Use: deriving (StaticByteSized, Binary) via (ViaStaticGeneric Foo)
newtype ViaStaticGeneric a = ViaStaticGeneric {forall a. ViaStaticGeneric a -> a
unViaStaticGeneric :: a}

instance (Generic t, GStaticByteSized (Rep t), GBinary (Rep t)) => Binary (ViaStaticGeneric t) where
  byteSize :: ViaStaticGeneric t -> ByteCount
byteSize ViaStaticGeneric t
sg = Proxy (Rep t) -> ByteCount
forall (f :: * -> *). GStaticByteSized f => Proxy f -> ByteCount
gstaticByteSize (ViaStaticGeneric t -> Rep t Any -> Proxy (Rep t)
forall (f :: * -> *) t a. f t -> Rep t a -> Proxy (Rep t)
proxyForRepF ViaStaticGeneric t
sg (t -> Rep t Any
forall x. t -> Rep t x
forall a x. Generic a => a -> Rep a x
from (ViaStaticGeneric t -> t
forall a. ViaStaticGeneric a -> a
unViaStaticGeneric ViaStaticGeneric t
sg)))
  get :: Get (ViaStaticGeneric t)
get = (Rep t Any -> ViaStaticGeneric t)
-> Get (Rep t Any) -> Get (ViaStaticGeneric t)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (t -> ViaStaticGeneric t
forall a. a -> ViaStaticGeneric a
ViaStaticGeneric (t -> ViaStaticGeneric t)
-> (Rep t Any -> t) -> Rep t Any -> ViaStaticGeneric t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep t Any -> t
forall a x. Generic a => Rep a x -> a
forall x. Rep t x -> t
to) Get (Rep t Any)
forall a. Get (Rep t a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget
  put :: ViaStaticGeneric t -> Put
put = (ViaStaticGeneric t -> Put) -> ViaStaticGeneric t -> Put
forall a. StaticByteSized a => (a -> Put) -> a -> Put
putStaticHint (Rep t Any -> Put
forall a. Rep t a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput (Rep t Any -> Put)
-> (ViaStaticGeneric t -> Rep t Any) -> ViaStaticGeneric t -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rep t Any
forall x. t -> Rep t x
forall a x. Generic a => a -> Rep a x
from (t -> Rep t Any)
-> (ViaStaticGeneric t -> t) -> ViaStaticGeneric t -> Rep t Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ViaStaticGeneric t -> t
forall a. ViaStaticGeneric a -> a
unViaStaticGeneric)

instance (GStaticByteSized (Rep t), KnownNat (GStaticSize (Rep t))) => StaticByteSized (ViaStaticGeneric t) where
  type StaticSize (ViaStaticGeneric t) = GStaticSize (Rep t)
  staticByteSize :: Proxy (ViaStaticGeneric t) -> ByteCount
staticByteSize Proxy (ViaStaticGeneric t)
_ = Proxy (Rep t) -> ByteCount
forall (f :: * -> *). GStaticByteSized f => Proxy f -> ByteCount
gstaticByteSize (Proxy (Rep t)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (Rep t))

-- ByteSized:

class GByteSized f where
  gbyteSize :: f a -> ByteCount

-- Unit
instance GByteSized U1 where
  gbyteSize :: forall a. U1 a -> ByteCount
gbyteSize U1 a
_ = ByteCount
0

-- Product
instance (GByteSized a, GByteSized b, o ~ n + m) => GByteSized (a :*: b) where
  gbyteSize :: forall a. (:*:) a b a -> ByteCount
gbyteSize (a a
x :*: b a
y) = a a -> ByteCount
forall a. a a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize a a
x ByteCount -> ByteCount -> ByteCount
forall a. Num a => a -> a -> a
+ b a -> ByteCount
forall a. b a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize b a
y

-- Metadata
instance (GByteSized a) => GByteSized (M1 i c a) where
  gbyteSize :: forall a. M1 i c a a -> ByteCount
gbyteSize = a a -> ByteCount
forall a. a a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize (a a -> ByteCount)
-> (M1 i c a a -> a a) -> M1 i c a a -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

-- Sum
instance (GByteSized a, GByteSized b, SumSize a, SumSize b) => GByteSized (a :+: b) where
  gbyteSize :: forall a. (:+:) a b a -> ByteCount
gbyteSize (:+:) a b a
s =
    (:+:) a b a -> ByteCount
forall (f :: * -> *) a. SumSize f => f a -> ByteCount
sumSizeBytes (:+:) a b a
s ByteCount -> ByteCount -> ByteCount
forall a. Num a => a -> a -> a
+ case (:+:) a b a
s of
      L1 a a
a -> a a -> ByteCount
forall a. a a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize a a
a
      R1 b a
b -> b a -> ByteCount
forall a. b a -> ByteCount
forall (f :: * -> *) a. GByteSized f => f a -> ByteCount
gbyteSize b a
b

-- Field
instance (Binary a) => GByteSized (K1 i a) where
  gbyteSize :: forall a. K1 i a a -> ByteCount
gbyteSize = a -> ByteCount
forall a. Binary a => a -> ByteCount
byteSize (a -> ByteCount) -> (K1 i a a -> a) -> K1 i a a -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1

-- StaticByteSized:

class (KnownNat (GStaticSize f)) => GStaticByteSized (f :: Type -> Type) where
  type GStaticSize f :: Nat
  gstaticByteSize :: Proxy f -> ByteCount
  gstaticByteSize = Integer -> ByteCount
forall a. Num a => Integer -> a
fromInteger (Integer -> ByteCount)
-> (Proxy f -> Integer) -> Proxy f -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (GStaticSize f) -> Integer
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (GStaticSize f) -> Integer)
-> (Proxy f -> Proxy (GStaticSize f)) -> Proxy f -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy f -> Proxy (GStaticSize f)
forall (f :: * -> *). Proxy f -> Proxy (GStaticSize f)
gstaticByteProxy

gstaticByteProxy :: Proxy f -> Proxy (GStaticSize f)
gstaticByteProxy :: forall (f :: * -> *). Proxy f -> Proxy (GStaticSize f)
gstaticByteProxy Proxy f
_ = Proxy (GStaticSize f)
forall {k} (t :: k). Proxy t
Proxy

instance GStaticByteSized U1 where
  type GStaticSize U1 = 0

instance (GStaticByteSized a, GStaticByteSized b) => GStaticByteSized (a :*: b) where
  type GStaticSize (a :*: b) = GStaticSize a + GStaticSize b

instance (GStaticByteSized a) => GStaticByteSized (M1 i c a) where
  type GStaticSize (M1 i c a) = GStaticSize a

instance (StaticByteSized a) => GStaticByteSized (K1 i a) where
  type GStaticSize (K1 i a) = StaticSize a

-- This one line is the reason all the nat constraints are threaded through this codebase
instance (GStaticByteSized a, GStaticByteSized b, GStaticSize a ~ GStaticSize b) => GStaticByteSized (a :+: b) where
  type GStaticSize (a :+: b) = GStaticSize a

-- Binary:

class GBinary (f :: Type -> Type) where
  gget :: Get (f a)
  gput :: f a -> Put

instance GBinary U1 where
  gget :: forall a. Get (U1 a)
gget = U1 a -> Get (U1 a)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1
  gput :: forall a. U1 a -> Put
gput U1 a
_ = () -> Put
forall a. a -> PutM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (GBinary a, GBinary b) => GBinary (a :*: b) where
  gget :: forall a. Get ((:*:) a b a)
gget = (a a -> b a -> (:*:) a b a)
-> Get (a a) -> Get (b a) -> Get ((:*:) a b a)
forall a b c. (a -> b -> c) -> Get a -> Get b -> Get c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) Get (a a)
forall a. Get (a a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget Get (b a)
forall a. Get (b a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget
  gput :: forall a. (:*:) a b a -> Put
gput (a a
x :*: b a
y) = a a -> Put
forall a. a a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput a a
x Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> b a -> Put
forall a. b a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput b a
y

instance (GBinary a) => GBinary (M1 i c a) where
  gget :: forall a. Get (M1 i c a a)
gget = (a a -> M1 i c a a) -> Get (a a) -> Get (M1 i c a a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 Get (a a)
forall a. Get (a a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget
  gput :: forall a. M1 i c a a -> Put
gput = a a -> Put
forall a. a a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput (a a -> Put) -> (M1 i c a a -> a a) -> M1 i c a a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (Binary a) => GBinary (K1 i a) where
  gget :: forall a. Get (K1 i a a)
gget = (a -> K1 i a a) -> Get a -> Get (K1 i a a)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 Get a
forall a. Binary a => Get a
get
  gput :: forall a. K1 i a a -> Put
gput = a -> Put
forall a. Binary a => a -> Put
put (a -> Put) -> (K1 i a a -> a) -> K1 i a a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1

-- Everything that follows is borrowed from the binary package, which
-- borrows from the cereal package!

-- The following GBinary instance for sums has support for serializing
-- types with up to 2^64-1 constructors. It will use the minimal
-- number of bytes needed to encode the constructor. For example when
-- a type has 2^8 constructors or less it will use a single byte to
-- encode the constructor. If it has 2^16 constructors or less it will
-- use two bytes, and so on till 2^64-1.

instance
  ( GSumBinary a
  , GSumBinary b
  , SumSize a
  , SumSize b
  )
  => GBinary (a :+: b)
  where
  gget :: forall a. Get ((:+:) a b a)
gget
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8 -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) = (Get Word8
forall a. Binary a => Get a
get :: Get Word8) Get Word8 -> (Word8 -> Get ((:+:) a b a)) -> Get ((:+:) a b a)
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Word8 -> Get ((:+:) a b a)
forall word (f :: * -> *) a.
(Ord word, Num word, Bits word, GSumBinary f) =>
word -> word -> Get (f a)
checkGetSum (Word32LE -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32LE
size)
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16LE -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16LE
forall a. Bounded a => a
maxBound :: Word16LE) = (Get Word16LE
forall a. Binary a => Get a
get :: Get Word16LE) Get Word16LE
-> (Word16LE -> Get ((:+:) a b a)) -> Get ((:+:) a b a)
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word16LE -> Word16LE -> Get ((:+:) a b a)
forall word (f :: * -> *) a.
(Ord word, Num word, Bits word, GSumBinary f) =>
word -> word -> Get (f a)
checkGetSum (Word32LE -> Word16LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32LE
size)
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word32LE
forall a. Bounded a => a
maxBound :: Word32LE) = (Get Word32LE
forall a. Binary a => Get a
get :: Get Word32LE) Get Word32LE
-> (Word32LE -> Get ((:+:) a b a)) -> Get ((:+:) a b a)
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word32LE -> Word32LE -> Get ((:+:) a b a)
forall word (f :: * -> *) a.
(Ord word, Num word, Bits word, GSumBinary f) =>
word -> word -> Get (f a)
checkGetSum Word32LE
size
    | Bool
otherwise = String -> Word32LE -> Get ((:+:) a b a)
forall size error. Show size => String -> size -> error
sizeError String
"decode" Word32LE
size
   where
    size :: Word32LE
size = Tagged (a :+: b) -> Word32LE
forall (s :: * -> *). Tagged s -> Word32LE
unTagged (Tagged (a :+: b)
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged (a :+: b))
  gput :: forall a. (:+:) a b a -> Put
gput
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8 -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) = Word8 -> Word8 -> (:+:) a b a -> Put
forall w a.
(Num w, Bits w, Binary w) =>
w -> w -> (:+:) a b a -> Put
forall (f :: * -> *) w a.
(GSumBinary f, Num w, Bits w, Binary w) =>
w -> w -> f a -> Put
putSum (Word8
0 :: Word8) (Word32LE -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32LE
size)
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16LE -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16LE
forall a. Bounded a => a
maxBound :: Word16LE) = Word16LE -> Word16LE -> (:+:) a b a -> Put
forall w a.
(Num w, Bits w, Binary w) =>
w -> w -> (:+:) a b a -> Put
forall (f :: * -> *) w a.
(GSumBinary f, Num w, Bits w, Binary w) =>
w -> w -> f a -> Put
putSum (Word16LE
0 :: Word16LE) (Word32LE -> Word16LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32LE
size)
    | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word32LE
forall a. Bounded a => a
maxBound :: Word32LE) = Word32LE -> Word32LE -> (:+:) a b a -> Put
forall w a.
(Num w, Bits w, Binary w) =>
w -> w -> (:+:) a b a -> Put
forall (f :: * -> *) w a.
(GSumBinary f, Num w, Bits w, Binary w) =>
w -> w -> f a -> Put
putSum (Word32LE
0 :: Word32LE) Word32LE
size
    | Bool
otherwise = String -> Word32LE -> (:+:) a b a -> Put
forall size error. Show size => String -> size -> error
sizeError String
"encode" Word32LE
size
   where
    size :: Word32LE
size = Tagged (a :+: b) -> Word32LE
forall (s :: * -> *). Tagged s -> Word32LE
unTagged (Tagged (a :+: b)
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged (a :+: b))

sizeError :: (Show size) => String -> size -> error
sizeError :: forall size error. Show size => String -> size -> error
sizeError String
s size
size = String -> error
forall a. HasCallStack => String -> a
error (String
"Can't " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" a type with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ size -> String
forall a. Show a => a -> String
show size
size String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" constructors")

checkGetSum
  :: (Ord word, Num word, Bits word, GSumBinary f)
  => word
  -> word
  -> Get (f a)
checkGetSum :: forall word (f :: * -> *) a.
(Ord word, Num word, Bits word, GSumBinary f) =>
word -> word -> Get (f a)
checkGetSum word
size word
code
  | word
code word -> word -> Bool
forall a. Ord a => a -> a -> Bool
< word
size = word -> word -> Get (f a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
forall (f :: * -> *) word a.
(GSumBinary f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum word
code word
size
  | Bool
otherwise = String -> Get (f a)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown encoding for constructor"
{-# INLINE checkGetSum #-}

class GSumBinary f where
  getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
  putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put

instance (GSumBinary a, GSumBinary b) => GSumBinary (a :+: b) where
  getSum :: forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get ((:+:) a b a)
getSum !word
code !word
size
    | word
code word -> word -> Bool
forall a. Ord a => a -> a -> Bool
< word
sizeL = a a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (a a -> (:+:) a b a) -> Get (a a) -> Get ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> word -> word -> Get (a a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (a a)
forall (f :: * -> *) word a.
(GSumBinary f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum word
code word
sizeL
    | Bool
otherwise = b a -> (:+:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (b a -> (:+:) a b a) -> Get (b a) -> Get ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> word -> word -> Get (b a)
forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (b a)
forall (f :: * -> *) word a.
(GSumBinary f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum (word
code word -> word -> word
forall a. Num a => a -> a -> a
- word
sizeL) word
sizeR
   where
    sizeL :: word
sizeL = word
size word -> Int -> word
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
    sizeR :: word
sizeR = word
size word -> word -> word
forall a. Num a => a -> a -> a
- word
sizeL
  putSum :: forall w a.
(Num w, Bits w, Binary w) =>
w -> w -> (:+:) a b a -> Put
putSum !w
code !w
size (:+:) a b a
s = case (:+:) a b a
s of
    L1 a a
x -> w -> w -> a a -> Put
forall w a. (Num w, Bits w, Binary w) => w -> w -> a a -> Put
forall (f :: * -> *) w a.
(GSumBinary f, Num w, Bits w, Binary w) =>
w -> w -> f a -> Put
putSum w
code w
sizeL a a
x
    R1 b a
x -> w -> w -> b a -> Put
forall w a. (Num w, Bits w, Binary w) => w -> w -> b a -> Put
forall (f :: * -> *) w a.
(GSumBinary f, Num w, Bits w, Binary w) =>
w -> w -> f a -> Put
putSum (w
code w -> w -> w
forall a. Num a => a -> a -> a
+ w
sizeL) w
sizeR b a
x
   where
    sizeL :: w
sizeL = w
size w -> Int -> w
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
    sizeR :: w
sizeR = w
size w -> w -> w
forall a. Num a => a -> a -> a
- w
sizeL

instance (GBinary a) => GSumBinary (C1 c a) where
  getSum :: forall word a.
(Ord word, Num word, Bits word) =>
word -> word -> Get (C1 c a a)
getSum word
_ word
_ = Get (M1 C c a a)
forall a. Get (M1 C c a a)
forall (f :: * -> *) a. GBinary f => Get (f a)
gget
  putSum :: forall w a. (Num w, Bits w, Binary w) => w -> w -> C1 c a a -> Put
putSum !w
code w
_ C1 c a a
x = w -> Put
forall a. Binary a => a -> Put
put w
code Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> C1 c a a -> Put
forall a. M1 C c a a -> Put
forall (f :: * -> *) a. GBinary f => f a -> Put
gput C1 c a a
x

class SumSize (f :: Type -> Type) where
  sumSize :: Tagged f

newtype Tagged (s :: Type -> Type) = Tagged {forall (s :: * -> *). Tagged s -> Word32LE
unTagged :: Word32LE}

instance (SumSize a, SumSize b) => SumSize (a :+: b) where
  sumSize :: Tagged (a :+: b)
sumSize = Word32LE -> Tagged (a :+: b)
forall (s :: * -> *). Word32LE -> Tagged s
Tagged (Tagged a -> Word32LE
forall (s :: * -> *). Tagged s -> Word32LE
unTagged (Tagged a
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged a) Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
+ Tagged b -> Word32LE
forall (s :: * -> *). Tagged s -> Word32LE
unTagged (Tagged b
forall (f :: * -> *). SumSize f => Tagged f
sumSize :: Tagged b))

instance SumSize (C1 c a) where
  sumSize :: Tagged (C1 c a)
sumSize = Word32LE -> Tagged (C1 c a)
forall (s :: * -> *). Word32LE -> Tagged s
Tagged Word32LE
1

sumSizeFor :: (SumSize f) => f a -> Tagged f
sumSizeFor :: forall (f :: * -> *) a. SumSize f => f a -> Tagged f
sumSizeFor = Tagged f -> f a -> Tagged f
forall a b. a -> b -> a
const Tagged f
forall (f :: * -> *). SumSize f => Tagged f
sumSize

taggedBytes :: Tagged f -> ByteCount
taggedBytes :: forall (f :: * -> *). Tagged f -> ByteCount
taggedBytes (Tagged Word32LE
size)
  | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8 -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
forall a. Bounded a => a
maxBound :: Word8) = ByteCount
1
  | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= Word16LE -> Word32LE
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16LE
forall a. Bounded a => a
maxBound :: Word16LE) = ByteCount
2
  | Word32LE
size Word32LE -> Word32LE -> Word32LE
forall a. Num a => a -> a -> a
- Word32LE
1 Word32LE -> Word32LE -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word32LE
forall a. Bounded a => a
maxBound :: Word32LE) = ByteCount
4
  | Bool
otherwise = String -> Word32LE -> ByteCount
forall size error. Show size => String -> size -> error
sizeError String
"size" Word32LE
size

sumSizeBytes :: (SumSize f) => f a -> ByteCount
sumSizeBytes :: forall (f :: * -> *) a. SumSize f => f a -> ByteCount
sumSizeBytes = Tagged f -> ByteCount
forall (f :: * -> *). Tagged f -> ByteCount
taggedBytes (Tagged f -> ByteCount) -> (f a -> Tagged f) -> f a -> ByteCount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Tagged f
forall (f :: * -> *) a. SumSize f => f a -> Tagged f
sumSizeFor