{-# LANGUAGE UndecidableInstances #-}

-- | Internal module. Not part of the public API.
module Data.PackStream.Generic
    ( GPackStream
    , genericToPs
    , genericFromPs
    , GenericPackStream(..)
    ) where

import           Compat.Prelude

import           Data.Kind (Constraint, Type)
import           GHC.Generics

import           Data.PackStream.Ps
import           Data.PackStream.Result

-- | Convert a value with a 'Generic' instance to a 'Ps' value.
genericToPs :: (Generic a, GPackStream (Rep a)) => a -> Ps
genericToPs :: forall a. (Generic a, GPackStream (Rep a)) => a -> Ps
genericToPs = Rep a Any -> Ps
forall a. Rep a a -> Ps
forall (f :: * -> *) a. GPackStream f => f a -> Ps
gToPs (Rep a Any -> Ps) -> (a -> Rep a Any) -> a -> Ps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

-- | Decode a 'Ps' value into a type with a 'Generic' instance.
genericFromPs :: (Generic a, GPackStream (Rep a)) => Ps -> Result a
genericFromPs :: forall a. (Generic a, GPackStream (Rep a)) => Ps -> Result a
genericFromPs Ps
x = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Result (Rep a Any) -> Result a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result (Rep a Any)
forall a. Ps -> Result (Rep a a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs Ps
x

-- | Newtype wrapper providing a 'PackStream' instance via 'GHC.Generics'.
type GenericPackStream :: Type -> Type
type role GenericPackStream representational
newtype GenericPackStream a = GenericPackStream a

instance (Generic a, GPackStream (Rep a)) => PackStream (GenericPackStream a) where
  toPs :: GenericPackStream a -> Ps
toPs (GenericPackStream a
a) = a -> Ps
forall a. (Generic a, GPackStream (Rep a)) => a -> Ps
genericToPs a
a
  fromPs :: Ps -> Result (GenericPackStream a)
fromPs Ps
a = a -> GenericPackStream a
forall a. a -> GenericPackStream a
GenericPackStream (a -> GenericPackStream a)
-> Result a -> Result (GenericPackStream a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result a
forall a. (Generic a, GPackStream (Rep a)) => Ps -> Result a
genericFromPs Ps
a

-- | Generic representation class for PackStream encoding\/decoding.
type GPackStream :: (Type -> Type) -> Constraint
class GPackStream f where
  gToPs   :: f a -> Ps
  gFromPs :: Ps -> Result (f a)

instance GPackStream U1 where
  gToPs :: forall a. U1 a -> Ps
gToPs U1 a
U1 = Ps
PsNull
  gFromPs :: forall a. Ps -> Result (U1 a)
gFromPs Ps
PsNull = U1 a -> Result (U1 a)
forall a. a -> Result a
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1
  gFromPs Ps
_      = String -> Result (U1 a)
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for custom unit type"

instance (GPackStream a, GProdPack b) => GPackStream (a :*: b) where
  gToPs :: forall a. (:*:) a b a -> Ps
gToPs = [Ps] -> Ps
forall a. PackStream a => a -> Ps
toPs ([Ps] -> Ps) -> ((:*:) a b a -> [Ps]) -> (:*:) a b a -> Ps
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:*:) a b a -> [Ps]
forall a. (:*:) a b a -> [Ps]
forall (f :: * -> *) a. GProdPack f => f a -> [Ps]
prodToPs
  gFromPs :: forall a. Ps -> Result ((:*:) a b a)
gFromPs = Ps -> Result [Ps]
forall a. PackStream a => Ps -> Result a
fromPs (Ps -> Result [Ps])
-> ([Ps] -> Result ((:*:) a b a)) -> Ps -> Result ((:*:) a b a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> [Ps] -> Result ((:*:) a b a)
forall a. [Ps] -> Result ((:*:) a b a)
forall (f :: * -> *) a. GProdPack f => [Ps] -> Result (f a)
prodFromPs

instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GPackStream (a :+: b) where
  gToPs :: forall a. (:+:) a b a -> Ps
gToPs = Int64 -> Int64 -> (:+:) a b a -> Ps
forall a. Int64 -> Int64 -> (:+:) a b a -> Ps
forall (f :: * -> *) a. GSumPack f => Int64 -> Int64 -> f a -> Ps
sumToPs Int64
0 Int64
size
    where
      size :: Int64
size = Tagged (a :+: b) Int64 -> Int64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Int64
forall (f :: * -> *). SumSize f => Tagged f Int64
sumSize :: Tagged (a :+: b) Int64)

  gFromPs :: forall a. Ps -> Result ((:+:) a b a)
gFromPs = \case
    PsInteger PSInteger
code -> Int64 -> Int64 -> Result ((:+:) a b a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Result (f a)
checkSumFromPs0 Int64
size (PSInteger -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral PSInteger
code)
    Ps
o              -> Ps -> Result (Int64, Ps)
forall a. PackStream a => Ps -> Result a
fromPs Ps
o Result (Int64, Ps)
-> ((Int64, Ps) -> Result ((:+:) a b a)) -> Result ((:+:) a b a)
forall a b. Result a -> (a -> Result b) -> Result b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Int64 -> Ps -> Result ((:+:) a b a))
-> (Int64, Ps) -> Result ((:+:) a b a)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int64 -> Int64 -> Ps -> Result ((:+:) a b a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
checkSumFromPs Int64
size)
    where
      size :: Int64
size = Tagged (a :+: b) Int64 -> Int64
forall (s :: * -> *) b. Tagged s b -> b
unTagged (Tagged (a :+: b) Int64
forall (f :: * -> *). SumSize f => Tagged f Int64
sumSize :: Tagged (a :+: b) Int64)

instance GPackStream a => GPackStream (M1 t c a) where
  gToPs :: forall a. M1 t c a a -> Ps
gToPs (M1 a a
x) = a a -> Ps
forall a. a a -> Ps
forall (f :: * -> *) a. GPackStream f => f a -> Ps
gToPs a a
x
  gFromPs :: forall a. Ps -> Result (M1 t c a a)
gFromPs Ps
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) -> Result (a a) -> Result (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result (a a)
forall a. Ps -> Result (a a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs Ps
x

instance PackStream a => GPackStream (K1 i a) where
  gToPs :: forall a. K1 i a a -> Ps
gToPs (K1 a
x) = a -> Ps
forall a. PackStream a => a -> Ps
toPs a
x
  gFromPs :: forall a. Ps -> Result (K1 i a a)
gFromPs Ps
o = a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a a) -> Result a -> Result (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result a
forall a. PackStream a => Ps -> Result a
fromPs Ps
o


-- Product type packing.

type GProdPack :: (Type -> Type) -> Constraint
class GProdPack f where
  prodToPs :: f a -> [Ps]
  prodFromPs :: [Ps] -> Result (f a)


instance (GPackStream a, GProdPack b) => GProdPack (a :*: b) where
  prodToPs :: forall a. (:*:) a b a -> [Ps]
prodToPs (a a
a :*: b a
b) = a a -> Ps
forall a. a a -> Ps
forall (f :: * -> *) a. GPackStream f => f a -> Ps
gToPs a a
a Ps -> [Ps] -> [Ps]
forall a. a -> [a] -> [a]
: b a -> [Ps]
forall a. b a -> [Ps]
forall (f :: * -> *) a. GProdPack f => f a -> [Ps]
prodToPs b a
b
  prodFromPs :: forall a. [Ps] -> Result ((:*:) a b a)
prodFromPs (Ps
a:[Ps]
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)
-> Result (a a) -> Result (b a -> (:*:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result (a a)
forall a. Ps -> Result (a a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs Ps
a Result (b a -> (:*:) a b a) -> Result (b a) -> Result ((:*:) a b a)
forall a b. Result (a -> b) -> Result a -> Result b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Ps] -> Result (b a)
forall a. [Ps] -> Result (b a)
forall (f :: * -> *) a. GProdPack f => [Ps] -> Result (f a)
prodFromPs [Ps]
b
  prodFromPs [Ps]
_     = String -> Result ((:*:) a b a)
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for product type"

instance GPackStream a => GProdPack (M1 t c a) where
  prodToPs :: forall a. M1 t c a a -> [Ps]
prodToPs (M1 a a
x) = [a a -> Ps
forall a. a a -> Ps
forall (f :: * -> *) a. GPackStream f => f a -> Ps
gToPs a a
x]
  prodFromPs :: forall a. [Ps] -> Result (M1 t c a a)
prodFromPs [Ps
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) -> Result (a a) -> Result (M1 t c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ps -> Result (a a)
forall a. Ps -> Result (a a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs Ps
x
  prodFromPs [Ps]
_   = String -> Result (M1 t c a a)
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for product type"


-- Sum type packing.

checkSumFromPs0 :: GSumPack f => Int64 -> Int64 -> Result (f a)
checkSumFromPs0 :: forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Result (f a)
checkSumFromPs0 Int64
size Int64
code
  | Int64
code Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
size = Int64 -> Int64 -> Ps -> Result (f a)
forall a. Int64 -> Int64 -> Ps -> Result (f a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
sumFromPs Int64
code Int64
size Ps
PsNull
  | Bool
otherwise   = String -> Result (f a)
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for sum type"


checkSumFromPs :: (GSumPack f) => Int64 -> Int64 -> Ps -> Result (f a)
checkSumFromPs :: forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
checkSumFromPs Int64
size Int64
code Ps
x
  | Int64
code Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
size = Int64 -> Int64 -> Ps -> Result (f a)
forall a. Int64 -> Int64 -> Ps -> Result (f a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
sumFromPs Int64
code Int64
size Ps
x
  | Bool
otherwise   = String -> Result (f a)
forall a. String -> Result a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"invalid encoding for sum type"


type GSumPack :: (Type -> Type) -> Constraint
class GSumPack f where
  sumToPs :: Int64 -> Int64 -> f a -> Ps
  sumFromPs :: Int64 -> Int64 -> Ps -> Result (f a)


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

  sumFromPs :: forall a. Int64 -> Int64 -> Ps -> Result ((:+:) a b a)
sumFromPs Int64
code Int64
size Ps
x
    | Int64
code Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
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) -> Result (a a) -> Result ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Int64 -> Ps -> Result (a a)
forall a. Int64 -> Int64 -> Ps -> Result (a a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
sumFromPs Int64
code           Int64
sizeL Ps
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) -> Result (b a) -> Result ((:+:) a b a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int64 -> Int64 -> Ps -> Result (b a)
forall a. Int64 -> Int64 -> Ps -> Result (b a)
forall (f :: * -> *) a.
GSumPack f =>
Int64 -> Int64 -> Ps -> Result (f a)
sumFromPs (Int64
code Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sizeL) Int64
sizeR Ps
x
    where
      sizeL :: Int64
sizeL = Int64
size Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
      sizeR :: Int64
sizeR = Int64
size Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
sizeL


instance {-# OVERLAPPING #-} GSumPack (C1 c U1) where
  sumToPs :: forall a. Int64 -> Int64 -> C1 c U1 a -> Ps
sumToPs Int64
code Int64
_ C1 c U1 a
_ = Int64 -> Ps
forall a. PackStream a => a -> Ps
toPs Int64
code
  sumFromPs :: forall a. Int64 -> Int64 -> Ps -> Result (C1 c U1 a)
sumFromPs Int64
_ Int64
_ = Ps -> Result (M1 C c U1 a)
forall a. Ps -> Result (M1 C c U1 a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs


instance {-# OVERLAPPABLE #-} GPackStream a => GSumPack (C1 c a) where
  sumToPs :: forall a. Int64 -> Int64 -> C1 c a a -> Ps
sumToPs Int64
code Int64
_ C1 c a a
x = (Int64, Ps) -> Ps
forall a. PackStream a => a -> Ps
toPs (Int64
code, C1 c a a -> Ps
forall a. M1 C c a a -> Ps
forall (f :: * -> *) a. GPackStream f => f a -> Ps
gToPs C1 c a a
x)
  sumFromPs :: forall a. Int64 -> Int64 -> Ps -> Result (C1 c a a)
sumFromPs Int64
_ Int64
_ = Ps -> Result (M1 C c a a)
forall a. Ps -> Result (M1 C c a a)
forall (f :: * -> *) a. GPackStream f => Ps -> Result (f a)
gFromPs


-- Sum size.

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

type Tagged :: (Type -> Type) -> Type -> Type
type role Tagged phantom representational
newtype Tagged (s :: Type -> Type) b = Tagged { forall (s :: * -> *) b. Tagged s b -> b
unTagged :: b }

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

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