{-# LANGUAGE AllowAmbiguousTypes       #-}
{-# LANGUAGE BangPatterns              #-}
{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DataKinds                 #-}
{-# LANGUAGE DefaultSignatures         #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE Trustworthy               #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}

-- |Generics-based generation of Flat instances
module Flat.Class
  (
  -- * The Flat class
    Flat(..)
  , getSize
  , module GHC.Generics
  , GFlatEncode,GFlatDecode,GFlatSize
  )
where

import           Data.Bits          (Bits (unsafeShiftL, (.|.)))
import           Data.Word          (Word16)
import           Flat.Decoder.Prim  (ConsState (..), consBits, consBool,
                                     consClose, consOpen, dBool)
import           Flat.Decoder.Types (Get)
import           Flat.Encoder       (Encoding, NumBits, eBits16, mempty)
import           GHC.Generics
import           GHC.TypeLits       (Nat, type (+), type (<=))
import           Prelude            hiding (mempty)

#if MIN_VERSION_base(4,9,0)
import           Data.Kind
#endif

#if ! MIN_VERSION_base(4,11,0)
import           Data.Semigroup     ((<>))
#endif


-- External and Internal inlining
#define INL 2
-- Internal inlining
-- #define INL 1
-- No inlining
-- #define INL 0

#if INL == 1
import           GHC.Exts           (inline)
#endif

-- import           Data.Proxy

-- |Calculate the maximum size in bits of the serialisation of the value
getSize :: Flat a => a -> NumBits
getSize :: forall a. Flat a => a -> NumBits
getSize a
a = forall a. Flat a => a -> NumBits -> NumBits
size a
a NumBits
0

{-| Class of types that can be encoded/decoded

Encoding a value involves three steps:

* calculate the maximum size of the serialised value, using `size`

* preallocate a buffer of the required size

* encode the value in the buffer, using `encode`
-}
class Flat a where
    -- |Return the encoding corrresponding to the value
    encode :: a -> Encoding
    default encode :: (Generic a, GFlatEncode (Rep a)) => a -> Encoding
    encode = forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => a -> Rep a x
from

    -- |Decode a value
    decode :: Get a
    default decode :: (Generic a, GFlatDecode (Rep a)) => Get a
    decode = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget

    -- |Add maximum size in bits of the value to the total count
    --
    --  Used to calculated maximum buffer size before encoding
    size :: a -> NumBits -> NumBits
    default size :: (Generic a, GFlatSize (Rep a)) => a -> NumBits -> NumBits
    size !a
x !NumBits
n = forall (f :: * -> *) a. GFlatSize f => NumBits -> f a -> NumBits
gsize NumBits
n forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from a
x

#if INL>=2
    -- With these, generated code is optimised for specific data types (e.g.: Tree Bool will fuse the code of Tree and Bool)
    -- This can improve performance very significantly (up to 10X) but also increases compilation times.
    {-# INLINE size #-}
    {-# INLINE decode #-}
    {-# INLINE encode #-}
#elif INL == 1
#elif INL == 0
    {-# NOINLINE size #-}
    {-# NOINLINE decode #-}
    {-# NOINLINE encode #-}
#endif

-- |Generic Encoder
class GFlatEncode f where gencode :: f a -> Encoding

instance {-# OVERLAPPABLE #-} GFlatEncode f => GFlatEncode (M1 i c f) where
      gencode :: forall a. M1 i c f a -> Encoding
gencode = forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
      {-# INLINE gencode #-}

  -- Special case, single constructor datatype
instance {-# OVERLAPPING #-} GFlatEncode a => GFlatEncode (D1 i (C1 c a)) where
      gencode :: forall a. D1 i (C1 c a) a -> Encoding
gencode = forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
      {-# INLINE gencode #-}

  -- Type without constructors
instance GFlatEncode V1 where
      gencode :: forall a. V1 a -> Encoding
gencode = forall a. a
unused
      {-# INLINE gencode #-}

  -- Constructor without arguments
instance GFlatEncode U1 where
      gencode :: forall a. U1 a -> Encoding
gencode U1 a
U1 = forall a. Monoid a => a
mempty
      {-# INLINE gencode #-}

instance Flat a => GFlatEncode (K1 i a) where
      {-# INLINE gencode #-}
#if INL == 1
      gencode x = inline encode (unK1 x)
#else
      gencode :: forall a. K1 i a a -> Encoding
gencode = forall a. Flat a => a -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i c (p :: k). K1 i c p -> c
unK1
#endif

instance (GFlatEncode a, GFlatEncode b) => GFlatEncode (a :*: b) where
      --gencode (!x :*: (!y)) = gencode x <++> gencode y
      gencode :: forall a. (:*:) a b a -> Encoding
gencode (a a
x :*: b a
y) = forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode a a
x forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode b a
y
      {-# INLINE gencode #-}

instance (NumConstructors (a :+: b) <= 512,GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where
-- instance (GFlatEncodeSum (a :+: b)) => GFlatEncode (a :+: b) where
      gencode :: forall a. (:+:) a b a -> Encoding
gencode = forall (f :: * -> *) a.
GFlatEncodeSum f =>
Word16 -> NumBits -> f a -> Encoding
gencodeSum Word16
0 NumBits
0
      {-# INLINE gencode #-}

-- Constructor Encoding
class GFlatEncodeSum f where
  gencodeSum :: Word16 -> NumBits -> f a -> Encoding

instance (GFlatEncodeSum a, GFlatEncodeSum b) => GFlatEncodeSum (a :+: b) where
  gencodeSum :: forall a. Word16 -> NumBits -> (:+:) a b a -> Encoding
gencodeSum !Word16
code !NumBits
numBits (:+:) a b a
s = case (:+:) a b a
s of
                           L1 !a a
x -> forall (f :: * -> *) a.
GFlatEncodeSum f =>
Word16 -> NumBits -> f a -> Encoding
gencodeSum (Word16
code forall a. Bits a => a -> NumBits -> a
`unsafeShiftL` NumBits
1) (NumBits
numBitsforall a. Num a => a -> a -> a
+NumBits
1) a a
x
                           R1 !b a
x -> forall (f :: * -> *) a.
GFlatEncodeSum f =>
Word16 -> NumBits -> f a -> Encoding
gencodeSum ((Word16
code forall a. Bits a => a -> NumBits -> a
`unsafeShiftL` NumBits
1) forall a. Bits a => a -> a -> a
.|. Word16
1) (NumBits
numBitsforall a. Num a => a -> a -> a
+NumBits
1) b a
x
  {-# INLINE  gencodeSum #-}

instance GFlatEncode a => GFlatEncodeSum (C1 c a) where
  gencodeSum :: forall a. Word16 -> NumBits -> C1 c a a -> Encoding
gencodeSum !Word16
code !NumBits
numBits C1 c a a
x = NumBits -> Word16 -> Encoding
eBits16 NumBits
numBits Word16
code forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. GFlatEncode f => f a -> Encoding
gencode C1 c a a
x
  {-# INLINE  gencodeSum #-}

-- |Generic Decoding
class GFlatDecode f where
  gget :: Get (f t)

-- |Metadata (constructor name, etc)
instance GFlatDecode a => GFlatDecode (M1 i c a) where
    gget :: forall t. Get (M1 i c a t)
gget = forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget
    {-# INLINE  gget #-}

-- |Type without constructors
instance GFlatDecode V1 where
    gget :: forall t. Get (V1 t)
gget = forall a. a
unused
    {-# INLINE  gget #-}

-- |Constructor without arguments
instance GFlatDecode U1 where
    gget :: forall t. Get (U1 t)
gget = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1
    {-# INLINE  gget #-}

-- |Product: constructor with parameters
instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :*: b) where
  gget :: forall t. Get ((:*:) a b t)
gget = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget
  {-# INLINE gget #-}

-- |Constants, additional parameters, and rank-1 recursion
instance Flat a => GFlatDecode (K1 i a) where
#if INL == 1
  gget = K1 <$> inline decode
#else
  gget :: forall t. Get (K1 i a t)
gget = forall k i c (p :: k). c -> K1 i c p
K1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Flat a => Get a
decode
#endif
  {-# INLINE gget #-}


-- Different valid decoding setups
-- #define DEC_BOOLG
-- #define DEC_BOOL

-- #define DEC_BOOLG
-- #define DEC_BOOL
-- #define DEC_BOOL48

-- #define DEC_CONS
-- #define DEC_BOOLC
-- #define DEC_BOOL

-- #define DEC_CONS
-- #define DEC_BOOLC
-- #define DEC_BOOL
-- #define DEC_BOOL48

-- #define DEC_CONS

-- #define DEC_CONS
-- #define DEC_CONS48

#define DEC_CONS
#define DEC_CONS48
#define DEC_BOOLC
#define DEC_BOOL

#ifdef DEC_BOOLG
instance (GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b)
#endif

#ifdef DEC_BOOLC
-- Special case for data types with two constructors
instance {-# OVERLAPPING #-} (GFlatDecode a,GFlatDecode b) => GFlatDecode (C1 m1 a :+: C1 m2 b)
#endif

#ifdef DEC_BOOL
  where
      gget :: forall t. Get ((:+:) (C1 m1 a) (C1 m2 b) t)
gget = do
        -- error "DECODE2_C2"
        !Bool
tag <- Get Bool
dBool
        !(:+:) (C1 m1 a) (C1 m2 b) t
r <- if Bool
tag then forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget else forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget
        forall (m :: * -> *) a. Monad m => a -> m a
return (:+:) (C1 m1 a) (C1 m2 b) t
r
      {-# INLINE gget #-}
#endif

#ifdef DEC_CONS
-- | Data types with up to 512 constructors
-- Uses a custom constructor decoding state
-- instance {-# OVERLAPPABLE #-} (GFlatDecodeSum (a :+: b),GFlatDecode a, GFlatDecode b) => GFlatDecode (a :+: b) where
instance {-# OVERLAPPABLE #-} (NumConstructors (a :+: b) <= 512, GFlatDecodeSum (a :+: b)) => GFlatDecode (a :+: b) where
  gget :: forall t. Get ((:+:) a b t)
gget = do
    ConsState
cs <- Get ConsState
consOpen
    forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs
  {-# INLINE gget #-}

-- |Constructor Decoder
class GFlatDecodeSum f where
    getSum :: ConsState -> Get (f a)

#ifdef DEC_CONS48

-- Decode constructors in groups of 2 or 3 bits
-- Significantly reduce instance compilation time and slightly improve execution times
instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4) => GFlatDecodeSum ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- getSum = undefined
      where
          getSum :: forall a. ConsState -> Get ((:+:) (n1 :+: n2) (n3 :+: n4) a)
getSum ConsState
cs = do
            -- error "DECODE4"
            let (ConsState
cs',Word
tag) = ConsState -> NumBits -> (ConsState, Word)
consBits ConsState
cs NumBits
2
            case Word
tag of
              Word
0 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
              Word
1 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
              Word
2 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
              Word
_ -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          {-# INLINE getSum #-}

instance {-# OVERLAPPING #-} (GFlatDecodeSum n1,GFlatDecodeSum n2,GFlatDecodeSum n3,GFlatDecodeSum n4,GFlatDecodeSum n5,GFlatDecodeSum n6,GFlatDecodeSum n7,GFlatDecodeSum n8) => GFlatDecodeSum (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- getSum cs = undefined
     where
      getSum :: forall a.
ConsState
-> Get
     ((:+:)
        ((n1 :+: n2) :+: (n3 :+: n4)) ((n5 :+: n6) :+: (n7 :+: n8)) a)
getSum ConsState
cs = do
        --error "DECODE8"
        let (ConsState
cs',Word
tag) = ConsState -> NumBits -> (ConsState, Word)
consBits ConsState
cs NumBits
3
        case Word
tag of
          Word
0 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
1 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
2 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
3 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
4 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
5 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
6 -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
          Word
_ -> forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
      {-# INLINE getSum #-}

instance {-# OVERLAPPABLE #-} (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where
#else
instance (GFlatDecodeSum a, GFlatDecodeSum b) => GFlatDecodeSum (a :+: b) where
#endif

  getSum :: forall a. ConsState -> Get ((:+:) a b a)
getSum ConsState
cs = do
    let (ConsState
cs',Bool
tag) = ConsState -> (ConsState, Bool)
consBool ConsState
cs
    if Bool
tag then forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs' else forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. GFlatDecodeSum f => ConsState -> Get (f a)
getSum ConsState
cs'
  {-# INLINE getSum #-}


instance GFlatDecode a => GFlatDecodeSum (C1 c a) where
    getSum :: forall a. ConsState -> Get (C1 c a a)
getSum (ConsState Word
_ NumBits
usedBits) = NumBits -> Get ()
consClose NumBits
usedBits forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) t. GFlatDecode f => Get (f t)
gget
    {-# INLINE getSum #-}
#endif

#ifdef DEC_BOOL48
instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4) => GFlatDecode ((n1 :+: n2) :+: (n3 :+: n4)) -- where -- gget = undefined
  where
      gget = do
        -- error "DECODE4"
        !tag <- dBEBits8 2
        case tag of
          0 -> L1 <$> L1 <$> gget
          1 -> L1 <$> R1 <$> gget
          2 -> R1 <$> L1 <$> gget
          _ -> R1 <$> R1 <$> gget
      {-# INLINE gget #-}

instance {-# OVERLAPPING #-} (GFlatDecode n1,GFlatDecode n2,GFlatDecode n3,GFlatDecode n4,GFlatDecode n5,GFlatDecode n6,GFlatDecode n7,GFlatDecode n8) => GFlatDecode (((n1 :+: n2) :+: (n3 :+: n4)) :+: ((n5 :+: n6) :+: (n7 :+: n8))) -- where -- gget = undefined
 where
  gget = do
    --error "DECODE8"
    !tag <- dBEBits8 3
    case tag of
      0 -> L1 <$> L1 <$> L1 <$> gget
      1 -> L1 <$> L1 <$> R1 <$> gget
      2 -> L1 <$> R1 <$> L1 <$> gget
      3 -> L1 <$> R1 <$> R1 <$> gget
      4 -> R1 <$> L1 <$> L1 <$> gget
      5 -> R1 <$> L1 <$> R1 <$> gget
      6 -> R1 <$> R1 <$> L1 <$> gget
      _ -> R1 <$> R1 <$> R1 <$> gget
  {-# INLINE gget #-}
#endif

-- |Calculate the number of bits required for the serialisation of a value
-- Implemented as a function that adds the maximum size to a running total
class GFlatSize f where gsize :: NumBits -> f a -> NumBits

-- |Skip metadata
instance GFlatSize f => GFlatSize (M1 i c f) where
    gsize :: forall a. NumBits -> M1 i c f a -> NumBits
gsize !NumBits
n = forall (f :: * -> *) a. GFlatSize f => NumBits -> f a -> NumBits
gsize NumBits
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1
    {-# INLINE gsize #-}

-- |Type without constructors
instance GFlatSize V1 where
    gsize :: forall a. NumBits -> V1 a -> NumBits
gsize !NumBits
n V1 a
_ = NumBits
n
    {-# INLINE gsize #-}

-- |Constructor without arguments
instance GFlatSize U1 where
    gsize :: forall a. NumBits -> U1 a -> NumBits
gsize !NumBits
n U1 a
_ = NumBits
n
    {-# INLINE gsize #-}

-- |Skip metadata
instance Flat a => GFlatSize (K1 i a) where
#if INL == 1
  gsize !n x = inline size (unK1 x) n
#else
  gsize :: forall a. NumBits -> K1 i a a -> NumBits
gsize !NumBits
n K1 i a a
x = forall a. Flat a => a -> NumBits -> NumBits
size (forall k i c (p :: k). K1 i c p -> c
unK1 K1 i a a
x) NumBits
n
#endif
  {-# INLINE gsize #-}

instance (GFlatSize a, GFlatSize b) => GFlatSize (a :*: b) where
    gsize :: forall a. NumBits -> (:*:) a b a -> NumBits
gsize !NumBits
n (a a
x :*: b a
y) =
      let !n' :: NumBits
n' = forall (f :: * -> *) a. GFlatSize f => NumBits -> f a -> NumBits
gsize NumBits
n a a
x
      in forall (f :: * -> *) a. GFlatSize f => NumBits -> f a -> NumBits
gsize NumBits
n' b a
y
      -- gsize (gsize n x) y
    {-# INLINE gsize #-}

-- Alternative 'gsize' implementations
#define SIZ_ADD
-- #define SIZ_NUM

-- #define SIZ_MAX
-- #define SIZ_MAX_VAL
-- #define SIZ_MAX_PROX

#ifdef SIZ_ADD
instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where
  gsize :: forall a. NumBits -> (:+:) a b a -> NumBits
gsize !NumBits
n = forall (f :: * -> *) a. GFlatSizeSum f => NumBits -> f a -> NumBits
gsizeSum NumBits
n
#endif

#ifdef SIZ_NUM
instance (GFlatSizeSum (a :+: b)) => GFlatSize (a :+: b) where
  gsize !n x = n + gsizeSum 0 x
#endif

#ifdef SIZ_MAX
instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where
  gsize !n x = gsizeNxt (gsizeMax x + n) x
  {-# INLINE gsize #-}

-- |Calculate the maximum size of a class constructor (that might be one bit more than the size of some of its constructors)
#ifdef SIZ_MAX_VAL
class GFlatSizeMax (f :: * -> *) where gsizeMax :: f a ->  NumBits

instance (GFlatSizeMax f, GFlatSizeMax g) => GFlatSizeMax (f :+: g) where
    gsizeMax _ = 1 + max (gsizeMax (undefined::f a )) (gsizeMax (undefined::g a))
    {-# INLINE gsizeMax #-}

instance (GFlatSize a) => GFlatSizeMax (C1 c a) where
    {-# INLINE gsizeMax #-}
    gsizeMax _ = 0
#endif

#ifdef SIZ_MAX_PROX
-- instance (GFlatSizeNxt (a :+: b),GFlatSizeMax (a:+:b)) => GFlatSize (a :+: b) where
--   gsize !n x = gsizeNxt (gsizeMax x + n) x
--   {-# INLINE gsize #-}


-- -- |Calculate size in bits of constructor
-- class KnownNat n => GFlatSizeMax (n :: Nat) (f :: * -> *) where gsizeMax :: f a -> Proxy n -> NumBits

-- instance (GFlatSizeMax (n + 1) a, GFlatSizeMax (n + 1) b, KnownNat n) => GFlatSizeMax n (a :+: b) where
--     gsizeMax !n x _ = case x of
--                         L1 !l -> gsizeMax n l (Proxy :: Proxy (n+1))
--                         R1 !r -> gsizeMax n r (Proxy :: Proxy (n+1))
--     {-# INLINE gsizeMax #-}

-- instance (GFlatSize a, KnownNat n) => GFlatSizeMax n (C1 c a) where
--     {-# INLINE gsizeMax #-}
--     gsizeMax !n !x _ = gsize (constructorSize + n) x
--       where
--         constructorSize :: NumBits
--         constructorSize = fromInteger (natVal (Proxy :: Proxy n))

-- class KnownNat (ConsSize f) => GFlatSizeMax (f :: * -> *) where
--   gsizeMax :: f a ->  NumBits
--   gsizeMax _ = fromInteger (natVal (Proxy :: Proxy (ConsSize f)))

type family ConsSize (a :: * -> *) :: Nat where
      ConsSize (C1 c a) = 0
      ConsSize (x :+: y) = 1 + Max (ConsSize x) (ConsSize y)

type family Max (n :: Nat) (m :: Nat) :: Nat where
   Max n m  = If (n <=? m) m n

type family If c (t::Nat) (e::Nat) where
    If 'True  t e = t
    If 'False t e = e
#endif

-- |Calculate the size of a value, not taking in account its constructor
class GFlatSizeNxt (f :: * -> *) where gsizeNxt :: NumBits -> f a ->  NumBits

instance (GFlatSizeNxt a, GFlatSizeNxt b) => GFlatSizeNxt (a :+: b) where
    gsizeNxt n x = case x of
                        L1 !l-> gsizeNxt n l
                        R1 !r-> gsizeNxt n r
    {-# INLINE gsizeNxt #-}

instance (GFlatSize a) => GFlatSizeNxt (C1 c a) where
    {-# INLINE gsizeNxt #-}
    gsizeNxt !n !x = gsize n x
#endif

-- |Calculate size in bits of constructor
-- vs proxy implementation: similar compilation time but much better run times (at least for Tree N, -70%)
#if MIN_VERSION_base(4,9,0)
class GFlatSizeSum (f :: Type -> Type) where
#else
class GFlatSizeSum (f :: * -> *) where
#endif
    gsizeSum :: NumBits -> f a ->  NumBits

instance (GFlatSizeSum a, GFlatSizeSum b)
         => GFlatSizeSum (a :+: b) where
    gsizeSum :: forall a. NumBits -> (:+:) a b a -> NumBits
gsizeSum !NumBits
n (:+:) a b a
x = case (:+:) a b a
x of
                        L1 !a a
l-> forall (f :: * -> *) a. GFlatSizeSum f => NumBits -> f a -> NumBits
gsizeSum (NumBits
nforall a. Num a => a -> a -> a
+NumBits
1) a a
l
                        R1 !b a
r-> forall (f :: * -> *) a. GFlatSizeSum f => NumBits -> f a -> NumBits
gsizeSum (NumBits
nforall a. Num a => a -> a -> a
+NumBits
1) b a
r
    {-# INLINE gsizeSum #-}

instance (GFlatSize a) => GFlatSizeSum (C1 c a) where
    {-# INLINE gsizeSum #-}
    gsizeSum :: forall a. NumBits -> C1 c a a -> NumBits
gsizeSum !NumBits
n !C1 c a a
x = forall (f :: * -> *) a. GFlatSize f => NumBits -> f a -> NumBits
gsize NumBits
n C1 c a a
x


-- |Calculate number of constructors
#if MIN_VERSION_base(4,9,0)
type family NumConstructors (a :: Type -> Type) :: Nat where
#else
type family NumConstructors (a :: * -> *) :: Nat where
#endif
  NumConstructors (C1 c a) = 1
  NumConstructors (x :+: y) = NumConstructors x + NumConstructors y

unused :: forall a . a
unused :: forall a. a
unused = forall a. HasCallStack => [Char] -> a
error [Char]
"Now, now, you could not possibly have meant this.."