{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures, TypeOperators #-}
{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-}
module Language.Souffle.Marshal
( Marshal(..)
, MonadPush(..)
, MonadPop(..)
, SimpleProduct
) where
import Type.Errors.Pretty
import GHC.Generics
import Data.Int
import Data.Word
import Data.Kind
import qualified Data.Text as T
import qualified Data.Text.Short as TS
import qualified Data.Text.Lazy as TL
class Monad m => MonadPush m where
pushInt32 :: Int32 -> m ()
pushUInt32 :: Word32 -> m ()
pushFloat :: Float -> m ()
pushString :: String -> m ()
pushText :: TS.ShortText -> m ()
pushTextUtf16 :: T.Text -> m ()
class Monad m => MonadPop m where
popInt32 :: m Int32
popUInt32 :: m Word32
popFloat :: m Float
popString :: m String
popText :: m TS.ShortText
popTextUtf16 :: m T.Text
class Marshal a where
push :: MonadPush m => a -> m ()
pop :: MonadPop m => m a
default push
:: (Generic a, SimpleProduct a, GMarshal (Rep a), MonadPush m)
=> a -> m ()
default pop
:: (Generic a, SimpleProduct a, GMarshal (Rep a), MonadPop m)
=> m a
push a
a = Rep a Any -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPush m) =>
f a -> m ()
gpush (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
a)
{-# INLINABLE push #-}
pop = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> m (Rep a Any) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Rep a Any)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPop m) =>
m (f a)
gpop
{-# INLINABLE pop #-}
instance Marshal Int32 where
push :: forall (m :: * -> *). MonadPush m => Int32 -> m ()
push = Int32 -> m ()
forall (m :: * -> *). MonadPush m => Int32 -> m ()
pushInt32
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m Int32
pop = m Int32
forall (m :: * -> *). MonadPop m => m Int32
popInt32
{-# INLINABLE pop #-}
instance Marshal Word32 where
push :: forall (m :: * -> *). MonadPush m => Word32 -> m ()
push = Word32 -> m ()
forall (m :: * -> *). MonadPush m => Word32 -> m ()
pushUInt32
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m Word32
pop = m Word32
forall (m :: * -> *). MonadPop m => m Word32
popUInt32
{-# INLINABLE pop #-}
instance Marshal Float where
push :: forall (m :: * -> *). MonadPush m => Float -> m ()
push = Float -> m ()
forall (m :: * -> *). MonadPush m => Float -> m ()
pushFloat
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m Float
pop = m Float
forall (m :: * -> *). MonadPop m => m Float
popFloat
{-# INLINABLE pop #-}
instance Marshal String where
push :: forall (m :: * -> *). MonadPush m => String -> m ()
push = String -> m ()
forall (m :: * -> *). MonadPush m => String -> m ()
pushString
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m String
pop = m String
forall (m :: * -> *). MonadPop m => m String
popString
{-# INLINABLE pop #-}
instance Marshal TS.ShortText where
push :: forall (m :: * -> *). MonadPush m => ShortText -> m ()
push = ShortText -> m ()
forall (m :: * -> *). MonadPush m => ShortText -> m ()
pushText
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m ShortText
pop = m ShortText
forall (m :: * -> *). MonadPop m => m ShortText
popText
{-# INLINABLE pop #-}
instance Marshal T.Text where
push :: forall (m :: * -> *). MonadPush m => Text -> m ()
push = Text -> m ()
forall (m :: * -> *). MonadPush m => Text -> m ()
pushTextUtf16
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m Text
pop = m Text
forall (m :: * -> *). MonadPop m => m Text
popTextUtf16
{-# INLINABLE pop #-}
instance Marshal TL.Text where
push :: forall (m :: * -> *). MonadPush m => Text -> m ()
push = Text -> m ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push (Text -> m ()) -> (Text -> Text) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict
{-# INLINABLE push #-}
pop :: forall (m :: * -> *). MonadPop m => m Text
pop = Text -> Text
TL.fromStrict (Text -> Text) -> m Text -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Text
forall a (m :: * -> *). (Marshal a, MonadPop m) => m a
pop
{-# INLINABLE pop #-}
class GMarshal f where
gpush :: MonadPush m => f a -> m ()
gpop :: MonadPop m => m (f a)
instance Marshal a => GMarshal (K1 i a) where
gpush :: forall (m :: * -> *) a. MonadPush m => K1 i a a -> m ()
gpush (K1 a
x) = a -> m ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push a
x
{-# INLINABLE gpush #-}
gpop :: forall (m :: * -> *) a. MonadPop m => m (K1 i a a)
gpop = 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
<$> m a
forall a (m :: * -> *). (Marshal a, MonadPop m) => m a
pop
{-# INLINABLE gpop #-}
instance (GMarshal f, GMarshal g) => GMarshal (f :*: g) where
gpush :: forall (m :: * -> *) a. MonadPush m => (:*:) f g a -> m ()
gpush (f a
a :*: g a
b) = do
f a -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPush m) =>
f a -> m ()
gpush f a
a
g a -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPush m) =>
f a -> m ()
gpush g a
b
{-# INLINABLE gpush #-}
gpop :: forall (m :: * -> *) a. MonadPop m => m ((:*:) f g a)
gpop = f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a) -> m (f a) -> m (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPop m) =>
m (f a)
gpop m (g a -> (:*:) f g a) -> m (g a) -> m ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (g a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPop m) =>
m (f a)
gpop
{-# INLINABLE gpop #-}
instance GMarshal a => GMarshal (M1 i c a) where
gpush :: forall (m :: * -> *) a. MonadPush m => M1 i c a a -> m ()
gpush (M1 a a
x) = a a -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPush m) =>
f a -> m ()
gpush a a
x
{-# INLINABLE gpush #-}
gpop :: forall (m :: * -> *) a. MonadPop m => m (M1 i c a a)
gpop = a a -> M1 i c a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a a -> M1 i c a a) -> m (a a) -> m (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPop m) =>
m (f a)
gpop
{-# INLINABLE gpop #-}
type family SimpleProduct (a :: Type) :: Constraint where
SimpleProduct a = (ProductLike a (Rep a), OnlyMarshallableFields (Rep a))
type family ProductLike (t :: Type) (f :: Type -> Type) :: Constraint where
ProductLike t (a :*: b) = (ProductLike t a, ProductLike t b)
ProductLike t (M1 _ _ a) = ProductLike t a
ProductLike _ (K1 _ _) = ()
ProductLike t (_ :+: _) =
TypeError ( "Error while deriving marshalling code for type " <> t <> ":"
% "Cannot derive sum type, only product types are supported.")
ProductLike t U1 =
TypeError ( "Error while deriving marshalling code for type " <> t <> ":"
% "Cannot automatically derive code for 0 argument constructor.")
ProductLike t V1 =
TypeError ( "Error while deriving marshalling code for type " <> t <> ":"
% "Cannot derive void type.")
type family OnlyMarshallableFields (f :: Type -> Type) :: Constraint where
OnlyMarshallableFields (a :*: b) = (OnlyMarshallableFields a, OnlyMarshallableFields b)
OnlyMarshallableFields (a :+: b) = (OnlyMarshallableFields a, OnlyMarshallableFields b)
OnlyMarshallableFields (M1 _ _ a) = OnlyMarshallableFields a
OnlyMarshallableFields U1 = ()
OnlyMarshallableFields V1 = ()
OnlyMarshallableFields k = OnlyMarshallableField k
type family OnlyMarshallableField (f :: Type -> Type) :: Constraint where
OnlyMarshallableField (M1 _ _ a) = OnlyMarshallableField a
OnlyMarshallableField (K1 _ a) = Marshal a