{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE CPP                  #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE IncoherentInstances  #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StrictData           #-}
{-# LANGUAGE Trustworthy          #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.MessagePack.Types.Generic () where

import           Control.Applicative                (Applicative, (<$>), (<*>))
import           Control.Monad                      ((>=>))
import           Control.Monad.Trans.State.Strict   (StateT, evalStateT, get,
                                                     put)
import           Control.Monad.Validate             (MonadValidate, refute)
import           Data.Bits                          (shiftR)
import           Data.Word                          (Word64)
import           GHC.Generics

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

instance GMessagePack V1 where
    gToObject :: Config -> V1 a -> Object
gToObject = Config -> V1 a -> Object
forall a. HasCallStack => a
undefined
    gFromObject :: Config -> Object -> m (V1 a)
gFromObject Config
_ Object
_ = DecodeError -> m (V1 a)
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"can't instantiate void type"

instance GMessagePack U1 where
    gToObject :: Config -> U1 a -> Object
gToObject Config
_ U1 a
U1 = Object
ObjectNil
    gFromObject :: Config -> Object -> m (U1 a)
gFromObject Config
_ 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 Config
_ Object
_         = DecodeError -> m (U1 a)
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"invalid encoding for custom unit type"

instance GProdPack a => GMessagePack a where
    gToObject :: Config -> a a -> Object
gToObject Config
cfg = Config -> [Object] -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
cfg ([Object] -> Object) -> (a a -> [Object]) -> a a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> a a -> [Object]
forall (f :: * -> *) a. GProdPack f => Config -> f a -> [Object]
prodToObject Config
cfg
    gFromObject :: Config -> Object -> m (a a)
gFromObject Config
cfg Object
o = do
        [Object]
list <- Config -> Object -> m [Object]
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m a
fromObjectWith Config
cfg Object
o
        StateT [Object] m (a a) -> [Object] -> m (a a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Config -> StateT [Object] m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GProdPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> StateT [Object] m (f a)
prodFromObject Config
cfg) [Object]
list

instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where
    gToObject :: Config -> (:+:) a b a -> Object
gToObject Config
cfg = Config -> Word64 -> Word64 -> (:+:) a b a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Config -> Word64 -> Word64 -> f a -> Object
sumToObject Config
cfg 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 :: Config -> Object -> m ((:+:) a b a)
gFromObject Config
cfg = \case
        ObjectWord Word64
code -> Config -> Word64 -> Word64 -> m ((:+:) a b a)
forall (m :: * -> *) (f :: * -> *) a.
(Applicative m, Monad m, MonadValidate DecodeError m,
 GSumPack f) =>
Config -> Word64 -> Word64 -> m (f a)
checkSumFromObject0 Config
cfg Word64
size (Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
code)
        Object
o               -> Config -> Object -> m (Word64, Object)
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m a
fromObjectWith Config
cfg 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 (Config -> Word64 -> Word64 -> Object -> m ((:+:) a b a)
forall (m :: * -> *) (f :: * -> *) a.
(Applicative m, Monad m, MonadValidate DecodeError m,
 GSumPack f) =>
Config -> Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject Config
cfg 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 :: Config -> M1 t c a a -> Object
gToObject Config
cfg (M1 a a
x) = Config -> a a -> Object
forall (f :: * -> *) a. GMessagePack f => Config -> f a -> Object
gToObject Config
cfg a a
x
    gFromObject :: Config -> Object -> m (M1 t c a a)
gFromObject Config
cfg 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
<$> Config -> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m (f a)
gFromObject Config
cfg Object
x

instance MessagePack a => GMessagePack (K1 i a) where
    gToObject :: Config -> K1 i a a -> Object
gToObject Config
cfg (K1 a
x) = Config -> a -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
cfg a
x
    gFromObject :: Config -> Object -> m (K1 i a a)
gFromObject Config
cfg 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
<$> Config -> Object -> m a
forall a (m :: * -> *).
(MessagePack a, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m a
fromObjectWith Config
cfg Object
o


-- Product type packing.

class GProdPack f where
    prodToObject :: Config -> f a -> [Object]
    prodFromObject
        :: ( Applicative m
           , Monad m
           , MonadValidate DecodeError m
           )
        => Config -> StateT [Object] m (f a)


instance (GProdPack a, GProdPack b) => GProdPack (a :*: b) where
    prodToObject :: Config -> (:*:) a b a -> [Object]
prodToObject Config
cfg (a a
a :*: b a
b) = Config -> a a -> [Object]
forall (f :: * -> *) a. GProdPack f => Config -> f a -> [Object]
prodToObject Config
cfg a a
a [Object] -> [Object] -> [Object]
forall a. [a] -> [a] -> [a]
++ Config -> b a -> [Object]
forall (f :: * -> *) a. GProdPack f => Config -> f a -> [Object]
prodToObject Config
cfg b a
b
    prodFromObject :: Config -> StateT [Object] m ((:*:) a b a)
prodFromObject Config
cfg = do
        a a
f <- Config -> StateT [Object] m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GProdPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> StateT [Object] m (f a)
prodFromObject Config
cfg
        b a
g <- Config -> StateT [Object] m (b a)
forall (f :: * -> *) (m :: * -> *) a.
(GProdPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> StateT [Object] m (f a)
prodFromObject Config
cfg
        (:*:) a b a -> StateT [Object] m ((:*:) a b a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((:*:) a b a -> StateT [Object] m ((:*:) a b a))
-> (:*:) a b a -> StateT [Object] m ((:*:) a b a)
forall a b. (a -> b) -> a -> b
$ a a
f a a -> b a -> (:*:) a b a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: b a
g

instance GMessagePack a => GProdPack (M1 t c a) where
    prodToObject :: Config -> M1 t c a a -> [Object]
prodToObject Config
cfg (M1 a a
x) = [Config -> a a -> Object
forall (f :: * -> *) a. GMessagePack f => Config -> f a -> Object
gToObject Config
cfg a a
x]
    prodFromObject :: Config -> StateT [Object] m (M1 t c a a)
prodFromObject Config
cfg = do
        [Object]
objs <- StateT [Object] m [Object]
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case [Object]
objs of
            (Object
x:[Object]
xs) -> do
                [Object] -> StateT [Object] m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [Object]
xs
                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)
-> StateT [Object] m (a a) -> StateT [Object] m (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Config -> Object -> StateT [Object] m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m (f a)
gFromObject Config
cfg Object
x
            [Object]
_      -> DecodeError -> StateT [Object] m (M1 t c a a)
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"invalid encoding for product type"


-- Sum type packing.

checkSumFromObject0
    :: ( Applicative m
       , Monad m
       , MonadValidate DecodeError m
       )
    => (GSumPack f) => Config -> Word64 -> Word64 -> m (f a)
checkSumFromObject0 :: Config -> Word64 -> Word64 -> m (f a)
checkSumFromObject0 Config
cfg Word64
size Word64
code
  | Word64
code Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
size = Config -> Word64 -> Word64 -> Object -> m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Word64 -> Word64 -> Object -> m (f a)
sumFromObject Config
cfg Word64
code Word64
size Object
ObjectNil
  | Bool
otherwise = DecodeError -> m (f a)
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"invalid encoding for sum type"


checkSumFromObject
    :: ( Applicative m
       , Monad m
       , MonadValidate DecodeError m
       )
    => (GSumPack f) => Config -> Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject :: Config -> Word64 -> Word64 -> Object -> m (f a)
checkSumFromObject Config
cfg Word64
size Word64
code Object
x
  | Word64
code Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
size = Config -> Word64 -> Word64 -> Object -> m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Word64 -> Word64 -> Object -> m (f a)
sumFromObject Config
cfg Word64
code Word64
size Object
x
  | Bool
otherwise   = DecodeError -> m (f a)
forall e (m :: * -> *) a. MonadValidate e m => e -> m a
refute DecodeError
"invalid encoding for sum type"


class GSumPack f where
    sumToObject :: Config -> Word64 -> Word64 -> f a -> Object
    sumFromObject
        :: ( Applicative m
           , Monad m
           , MonadValidate DecodeError m
           )
        => Config
        -> Word64
        -> Word64
        -> Object
        -> m (f a)


instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where
    sumToObject :: Config -> Word64 -> Word64 -> (:+:) a b a -> Object
sumToObject Config
cfg Word64
code Word64
size = \case
        L1 a a
x -> Config -> Word64 -> Word64 -> a a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Config -> Word64 -> Word64 -> f a -> Object
sumToObject Config
cfg Word64
code Word64
sizeL a a
x
        R1 b a
x -> Config -> Word64 -> Word64 -> b a -> Object
forall (f :: * -> *) a.
GSumPack f =>
Config -> Word64 -> Word64 -> f a -> Object
sumToObject Config
cfg (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 :: Config -> Word64 -> Word64 -> Object -> m ((:+:) a b a)
sumFromObject Config
cfg 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
<$> Config -> Word64 -> Word64 -> Object -> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Word64 -> Word64 -> Object -> m (f a)
sumFromObject Config
cfg 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
<$> Config -> Word64 -> Word64 -> Object -> m (b a)
forall (f :: * -> *) (m :: * -> *) a.
(GSumPack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Word64 -> Word64 -> Object -> m (f a)
sumFromObject Config
cfg (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 :: Config -> Word64 -> Word64 -> C1 c U1 a -> Object
sumToObject Config
cfg Word64
code Word64
_ C1 c U1 a
_ = Config -> Word64 -> Object
forall a. MessagePack a => Config -> a -> Object
toObject Config
cfg Word64
code
    sumFromObject :: Config -> Word64 -> Word64 -> Object -> m (C1 c U1 a)
sumFromObject Config
cfg Word64
_ Word64
_ = Config -> Object -> m (C1 c U1 a)
forall (f :: * -> *) (m :: * -> *) a.
(GMessagePack f, Applicative m, Monad m,
 MonadValidate DecodeError m) =>
Config -> Object -> m (f a)
gFromObject Config
cfg


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


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