{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,
    ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}
{-# LANGUAGE Safe #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#if __GLASGOW_HASKELL__ >= 800
#define HAS_DATA_KIND
#endif

-----------------------------------------------------------------------------
-- |
-- Module      : Data.Binary.Generic
-- Copyright   : Bryan O'Sullivan
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>
-- Stability   : unstable
-- Portability : Only works with GHC 7.2 and newer
--
-- Instances for supporting GHC generics.
--
-----------------------------------------------------------------------------
module Data.Binary.Generic
    (
    ) where

import Control.Applicative
import Data.Binary.Class
import Data.Binary.Get
import Data.Binary.Put
import Data.Bits
import Data.Word
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ((<>))
#endif
#ifdef HAS_DATA_KIND
import Data.Kind
#endif
import GHC.Generics
import Prelude -- Silence AMP warning.

-- Type without constructors
instance GBinaryPut V1 where
    gput :: V1 t -> Put
gput V1 t
_ = () -> Put
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance GBinaryGet V1 where
    gget :: Get (V1 t)
gget   = V1 t -> Get (V1 t)
forall (m :: * -> *) a. Monad m => a -> m a
return V1 t
forall a. HasCallStack => a
undefined

-- Constructor without arguments
instance GBinaryPut U1 where
    gput :: U1 t -> Put
gput U1 t
U1 = () -> Put
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance GBinaryGet U1 where
    gget :: Get (U1 t)
gget    = U1 t -> Get (U1 t)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 t
forall k (p :: k). U1 p
U1

-- Product: constructor with parameters
instance (GBinaryPut a, GBinaryPut b) => GBinaryPut (a :*: b) where
    gput :: (:*:) a b t -> Put
gput (a t
x :*: b t
y) = a t -> Put
forall k (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput a t
x Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> b t -> Put
forall k (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput b t
y

instance (GBinaryGet a, GBinaryGet b) => GBinaryGet (a :*: b) where
    gget :: Get ((:*:) a b t)
gget = a t -> b t -> (:*:) a b t
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a t -> b t -> (:*:) a b t)
-> Get (a t) -> Get (b t -> (:*:) a b t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (a t)
forall k (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget Get (b t -> (:*:) a b t) -> Get (b t) -> Get ((:*:) a b t)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (b t)
forall k (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget

-- Metadata (constructor name, etc)
instance GBinaryPut a => GBinaryPut (M1 i c a) where
    gput :: M1 i c a t -> Put
gput = a t -> Put
forall k (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput (a t -> Put) -> (M1 i c a t -> a t) -> M1 i c a t -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c a t -> a t
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance GBinaryGet a => GBinaryGet (M1 i c a) where
    gget :: Get (M1 i c a t)
gget = a t -> M1 i c a t
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a t -> M1 i c a t) -> Get (a t) -> Get (M1 i c a t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (a t)
forall k (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget

-- Constants, additional parameters, and rank-1 recursion
instance Binary a => GBinaryPut (K1 i a) where
    gput :: K1 i a t -> Put
gput = a -> Put
forall t. Binary t => t -> Put
put (a -> Put) -> (K1 i a t -> a) -> K1 i a t -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a t -> a
forall i c k (p :: k). K1 i c p -> c
unK1

instance Binary a => GBinaryGet (K1 i a) where
    gget :: Get (K1 i a t)
gget = a -> K1 i a t
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a t) -> Get a -> Get (K1 i a t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall t. Binary t => Get t
get

-- Borrowed 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.

#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)
#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)

instance ( GSumPut  a, GSumPut  b
         , SumSize    a, SumSize    b) => GBinaryPut (a :+: b) where
    gput :: (:+:) a b t -> Put
gput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
         | Bool
otherwise = String -> Word64 -> (:+:) a b t -> Put
forall size error. Show size => String -> size -> error
sizeError String
"encode" Word64
size
      where
        size :: Word64
size = Tagged (a :+: b) Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged (a :+: b) Word64)

instance ( GSumGet  a, GSumGet  b
         , SumSize    a, SumSize    b) => GBinaryGet (a :+: b) where
    gget :: Get ((:+:) a b t)
gget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)
         | Bool
otherwise = String -> Word64 -> Get ((:+:) a b t)
forall size error. Show size => String -> size -> error
sizeError String
"decode" Word64
size
      where
        size :: Word64
size = Tagged (a :+: b) Word64 -> Word64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Word64
forall (f :: * -> *). SumSize f => Tagged f Word64
sumSize :: Tagged (a :+: b) Word64)

sizeError :: Show size => String -> size -> error
sizeError :: String -> size -> error
sizeError String
s size
size =
    String -> error
forall a. HasCallStack => String -> a
error (String -> error) -> String -> error
forall a b. (a -> b) -> a -> b
$ 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, GSumGet f)
            => word -> word -> Get (f a)
checkGetSum :: 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 (f :: * -> *) word a.
(GSumGet f, Ord word, Num word, Bits word) =>
word -> word -> Get (f a)
getSum word
code word
size
                      | Bool
otherwise   = String -> Get (f a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unknown encoding for constructor"
{-# INLINE checkGetSum #-}

class GSumGet f where
    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)

class GSumPut f where
    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put

instance (GSumGet a, GSumGet b) => GSumGet (a :+: b) where
    getSum :: 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 (f :: * -> *) word a.
(GSumGet 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 (f :: * -> *) word a.
(GSumGet 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

instance (GSumPut a, GSumPut b) => GSumPut (a :+: b) where
    putSum :: 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 (f :: * -> *) w a.
(GSumPut 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 (f :: * -> *) w a.
(GSumPut 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 GBinaryGet a => GSumGet (C1 c a) where
    getSum :: word -> word -> Get (C1 c a a)
getSum word
_ word
_ = Get (C1 c a a)
forall k (f :: k -> *) (t :: k). GBinaryGet f => Get (f t)
gget

instance GBinaryPut a => GSumPut (C1 c a) where
    putSum :: w -> w -> C1 c a a -> Put
putSum !w
code w
_ C1 c a a
x = w -> Put
forall t. Binary t => t -> Put
put w
code Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> C1 c a a -> Put
forall k (f :: k -> *) (t :: k). GBinaryPut f => f t -> Put
gput C1 c a a
x

------------------------------------------------------------------------

class SumSize f where
    sumSize :: Tagged f Word64

#ifdef HAS_DATA_KIND
newtype Tagged (s :: Type -> Type) b = Tagged {Tagged s b -> b
unTagged :: b}
#else
newtype Tagged (s :: * -> *)       b = Tagged {unTagged :: b}
#endif

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

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