{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE IncoherentInstances #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE Safe                #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData          #-}
{-# LANGUAGE TypeOperators       #-}
module Data.MessagePack.Types.Generic () where

import           Control.Applicative           (Applicative, (<$>), (<*>))
import           Control.Monad                 ((>=>))
import           Data.Bits                     (shiftR)
import           Data.Word                     (Word64)
import           GHC.Generics

import           Data.MessagePack.Types.Class
import           Data.MessagePack.Types.Object (Object (..))

instance GMessagePack V1 where
    gToObject :: V1 a -> Object
gToObject = V1 a -> Object
forall a. HasCallStack => a
undefined
    gFromObject :: Object -> m (V1 a)
gFromObject Object
_ = String -> m (V1 a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"can't instantiate void type"

instance GMessagePack U1 where
    gToObject :: U1 a -> Object
gToObject U1 a
U1 = Object
ObjectNil
    gFromObject :: Object -> m (U1 a)
gFromObject Object
ObjectNil = U1 a -> m (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
    gFromObject Object
_         = String -> m (U1 a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for custom unit type"

instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where
    gToObject :: (:*:) a b a -> Object
gToObject   = [Object] -> Object
forall a. MessagePack a => a -> Object
toObject ([Object] -> Object)
-> ((:*:) a b a -> [Object]) -> (:*:) a b a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:*:) a b a -> [Object]
forall (f :: * -> *) a. GProdPack f => f a -> [Object]
prodToObject
    gFromObject :: Object -> m ((:*:) a b a)
gFromObject = Object -> m [Object]
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
Object -> m a
fromObject (Object -> m [Object])
-> ([Object] -> m ((:*:) a b a)) -> Object -> m ((:*:) a b a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Object] -> m ((:*:) a b a)
forall (f :: * -> *) (m :: * -> *) a.
(GProdPack f, Applicative m, Monad m, MonadFail m) =>
[Object] -> m (f a)
prodFromObject

instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where
    gToObject :: (:+:) a b a -> Object
gToObject = Word64 -> Word64 -> (:+:) a b a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Word64 -> Word64 -> f a -> Object
sumToObject Word64
0 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)

    gFromObject :: Object -> m ((:+:) a b a)
gFromObject = \case
        ObjectWord Word64
code -> Word64 -> Word64 -> m ((:+:) a b a)
forall (m :: * -> *) (f :: * -> *) a.
(Applicative m, Monad m, MonadFail m, GSumPack f) =>
Word64 -> Word64 -> m (f a)
checkSumFromObject0 Word64
size (Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
code)
        Object
o               -> Object -> m (Word64, Object)
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
Object -> m a
fromObject Object
o m (Word64, Object)
-> ((Word64, Object) -> m ((:+:) a b a)) -> m ((:+:) a b a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Word64 -> Object -> m ((:+:) a b a))
-> (Word64, Object) -> m ((:+:) a b a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Word64 -> Word64 -> Object -> m ((:+:) a b a)
forall (m :: * -> *) (f :: * -> *) a.
(Applicative m, Monad m, MonadFail m, GSumPack f) =>
Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject 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 GMessagePack a => GMessagePack (M1 t c a) where
    gToObject :: M1 t c a a -> Object
gToObject (M1 a a
x) = a a -> Object
forall (f :: * -> *) a. GMessagePack f => f a -> Object
gToObject a a
x
    gFromObject :: Object -> m (M1 t c a a)
gFromObject Object
x = a a -> M1 t c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 t c a a) -> m (a a) -> m (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m, MonadFail m) =>
Object -> m (f a)
gFromObject Object
x

instance MessagePack a => GMessagePack (K1 i a) where
    gToObject :: K1 i a a -> Object
gToObject (K1 a
x) = a -> Object
forall a. MessagePack a => a -> Object
toObject a
x
    gFromObject :: Object -> m (K1 i a a)
gFromObject Object
o = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> m a -> m (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> m a
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m, MonadFail m) =>
Object -> m a
fromObject Object
o


-- Product type packing.

class GProdPack f where
    prodToObject :: f a -> [Object]
    prodFromObject
        :: ( Applicative m
           , Monad m
#if (MIN_VERSION_base(4,13,0))
           , MonadFail m
#endif
           )
        => [Object]
        -> m (f a)


instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where
    prodToObject :: (:*:) a b a -> [Object]
prodToObject (a a
a :*: b a
b) = a a -> Object
forall (f :: * -> *) a. GMessagePack f => f a -> Object
gToObject a a
a Object -> [Object] -> [Object]
forall a. a -> [a] -> [a]
: b a -> [Object]
forall (f :: * -> *) a. GProdPack f => f a -> [Object]
prodToObject b a
b
    prodFromObject :: [Object] -> m ((:*:) a b a)
prodFromObject (Object
a : [Object]
b) = a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (a a -> b a -> (:*:) a b a) -> m (a a) -> m (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m, MonadFail m) =>
Object -> m (f a)
gFromObject Object
a m (b a -> (:*:) a b a) -> m (b a) -> m ((:*:) a b a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Object] -> m (b a)
forall (f :: * -> *) (m :: * -> *) a.
(GProdPack f, Applicative m, Monad m, MonadFail m) =>
[Object] -> m (f a)
prodFromObject [Object]
b
    prodFromObject []      = String -> m ((:*:) a b a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for product type"

instance GMessagePack a => GProdPack (M1 t c a) where
    prodToObject :: M1 t c a a -> [Object]
prodToObject (M1 a a
x) = [a a -> Object
forall (f :: * -> *) a. GMessagePack f => f a -> Object
gToObject a a
x]
    prodFromObject :: [Object] -> m (M1 t c a a)
prodFromObject [Object
x] = a a -> M1 t c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 t c a a) -> m (a a) -> m (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m, MonadFail m) =>
Object -> m (f a)
gFromObject Object
x
    prodFromObject [Object]
_   = String -> m (M1 t c a a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for product type"


-- Sum type packing.

checkSumFromObject0
    :: ( Applicative m
       , Monad m
#if (MIN_VERSION_base(4,13,0))
       , MonadFail m
#endif
       )
    => (GSumPack f) => Word64 -> Word64 -> m (f a)
checkSumFromObject0 :: Word64 -> Word64 -> m (f a)
checkSumFromObject0 Word64
size Word64
code | Word64
code Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
size = Word64 -> Word64 -> Object -> m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m, MonadFail m) =>
Word64 -> Word64 -> Object -> m (f a)
sumFromObject Word64
code Word64
size Object
ObjectNil
                              | Bool
otherwise = String -> m (f a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for sum type"


checkSumFromObject
    :: ( Applicative m
       , Monad m
#if (MIN_VERSION_base(4,13,0))
       , MonadFail m
#endif
       )
    => (GSumPack f) => Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject :: Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject Word64
size Word64
code Object
x
    | Word64
code Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
size = Word64 -> Word64 -> Object -> m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m, MonadFail m) =>
Word64 -> Word64 -> Object -> m (f a)
sumFromObject Word64
code Word64
size Object
x
    | Bool
otherwise   = String -> m (f a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for sum type"


class GSumPack f where
    sumToObject :: Word64 -> Word64 -> f a -> Object
    sumFromObject
        :: ( Applicative m
           , Monad m
#if (MIN_VERSION_base(4,13,0))
           , MonadFail m
#endif
           )
        => Word64
        -> Word64
        -> Object
        -> m (f a)


instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where
    sumToObject :: Word64 -> Word64 -> (:+:) a b a -> Object
sumToObject Word64
code Word64
size = \case
        L1 a a
x -> Word64 -> Word64 -> a a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Word64 -> Word64 -> f a -> Object
sumToObject Word64
code Word64
sizeL a a
x
        R1 b a
x -> Word64 -> Word64 -> b a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Word64 -> Word64 -> f a -> Object
sumToObject (Word64
code Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
sizeL) Word64
sizeR b a
x
      where
        sizeL :: Word64
sizeL = Word64
size Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
        sizeR :: Word64
sizeR = Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
sizeL

    sumFromObject :: Word64 -> Word64 -> Object -> m ((:+:) a b a)
sumFromObject Word64
code Word64
size Object
x
        | Word64
code Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
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) -> m (a a) -> m ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Word64 -> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m, MonadFail m) =>
Word64 -> Word64 -> Object -> m (f a)
sumFromObject Word64
code Word64
sizeL Object
x
        | 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) -> m (b a) -> m ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Word64 -> Object -> m (b a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m, MonadFail m) =>
Word64 -> Word64 -> Object -> m (f a)
sumFromObject (Word64
code Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
sizeL) Word64
sizeR Object
x
      where
        sizeL :: Word64
sizeL = Word64
size Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
        sizeR :: Word64
sizeR = Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
sizeL


instance GSumPack (C1 c U1) where
    sumToObject :: Word64 -> Word64 -> C1 c U1 a -> Object
sumToObject Word64
code Word64
_ C1 c U1 a
_ = Word64 -> Object
forall a. MessagePack a => a -> Object
toObject Word64
code
    sumFromObject :: Word64 -> Word64 -> Object -> m (C1 c U1 a)
sumFromObject Word64
_ Word64
_ = Object -> m (C1 c U1 a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m, MonadFail m) =>
Object -> m (f a)
gFromObject


instance GMessagePack a => GSumPack (C1 c a) where
    sumToObject :: Word64 -> Word64 -> C1 c a a -> Object
sumToObject Word64
code Word64
_ C1 c a a
x = (Word64, Object) -> Object
forall a. MessagePack a => a -> Object
toObject (Word64
code, C1 c a a -> Object
forall (f :: * -> *) a. GMessagePack f => f a -> Object
gToObject C1 c a a
x)
    sumFromObject :: Word64 -> Word64 -> Object -> m (C1 c a a)
sumFromObject Word64
_ Word64
_ = Object -> m (C1 c a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m, MonadFail m) =>
Object -> m (f a)
gFromObject


-- Sum size.

class SumSize f where
    sumSize :: Tagged f Word64

newtype Tagged (s :: * -> *) b = Tagged { Tagged s b -> b
unTagged :: b }

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