{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE DefaultSignatures, TypeOperators #-}

-- | This module exposes a uniform interface to marshal values
--   to and from Souffle Datalog. This is done via the 'Marshal' typeclass.
--   Also, a mechanism is exposed for generically deriving marshalling
--   and unmarshalling code for simple product types.
module Language.Souffle.Marshal
  ( Marshal(..)
  , MonadPush(..)
  , MonadPop(..)
  ) where

import GHC.Generics
import Data.Int
import Data.Word
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Language.Souffle.Internal.Constraints as C

{- | A typeclass for serializing primitive values from Haskell to Datalog.

This typeclass is only used internally and subject to change.

See also: 'MonadPop', 'Marshal'.
-}
class Monad m => MonadPush m where
  -- | Marshals a signed 32 bit integer to the datalog side.
  pushInt32 :: Int32 -> m ()
  -- | Marshals an unsigned 32 bit integer to the datalog side.
  pushUInt32 :: Word32 -> m ()
  -- | Marshals a float to the datalog side.
  pushFloat :: Float -> m ()
  -- | Marshals a string to the datalog side.
  pushString :: String -> m ()

{- | A typeclass for serializing primitive values from Datalog to Haskell.

This typeclass is only used internally and subject to change.

See also: 'MonadPush', 'Marshal'.
-}
class Monad m => MonadPop m where
  -- | Unmarshals a signed 32 bit integer from the datalog side.
  popInt32 :: m Int32
  -- | Unmarshals an unsigned 32 bit integer from the datalog side.
  popUInt32 :: m Word32
  -- | Unmarshals a float from the datalog side.
  popFloat :: m Float
  -- | Unmarshals a string from the datalog side.
  popString :: m String

{- | A typeclass for providing a uniform API to marshal/unmarshal values
     between Haskell and Souffle datalog.

The marshalling is done via a stack-based approach, where elements are
pushed/popped one by one. You need to make sure that the marshalling
of values happens in the correct order or unexpected things might happen
(including crashes). Pushing and popping of fields should happen in the
same order (from left to right, as defined in Datalog).

Generic implementations for 'push' and 'pop' that perform the previously
described behavior are available. This makes it possible to
write very succinct code:

@
data Edge = Edge String String deriving Generic

instance Marshal Edge
@
-}
class Marshal a where
  -- | Marshals a value to the datalog side.
  push :: MonadPush m => a -> m ()
  -- | Unmarshals a value from the datalog side.
  pop :: MonadPop m => m a

  default push
    :: (Generic a, C.SimpleProduct a, GMarshal (Rep a), MonadPush m)
    => a -> m ()
  default pop
    :: (Generic a, C.SimpleProduct a, GMarshal (Rep a), MonadPop m)
    => m a
  push a :: 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 :: Int32 -> m ()
push = Int32 -> m ()
forall (m :: * -> *). MonadPush m => Int32 -> m ()
pushInt32
  {-# INLINABLE push #-}
  pop :: m Int32
pop = m Int32
forall (m :: * -> *). MonadPop m => m Int32
popInt32
  {-# INLINABLE pop #-}

instance Marshal Word32 where
  push :: Word32 -> m ()
push = Word32 -> m ()
forall (m :: * -> *). MonadPush m => Word32 -> m ()
pushUInt32
  {-# INLINABLE push #-}
  pop :: m Word32
pop = m Word32
forall (m :: * -> *). MonadPop m => m Word32
popUInt32
  {-# INLINABLE pop #-}

instance Marshal Float where
  push :: Float -> m ()
push = Float -> m ()
forall (m :: * -> *). MonadPush m => Float -> m ()
pushFloat
  {-# INLINABLE push #-}
  pop :: m Float
pop = m Float
forall (m :: * -> *). MonadPop m => m Float
popFloat
  {-# INLINABLE pop #-}

instance Marshal String where
  push :: String -> m ()
push = String -> m ()
forall (m :: * -> *). MonadPush m => String -> m ()
pushString
  {-# INLINABLE push #-}
  pop :: m String
pop = m String
forall (m :: * -> *). MonadPop m => m String
popString
  {-# INLINABLE pop #-}

instance Marshal T.Text where
  push :: Text -> m ()
push = String -> m ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push (String -> m ()) -> (Text -> String) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
  {-# INLINABLE push #-}
  pop :: m Text
pop = String -> Text
T.pack (String -> Text) -> m String -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall a (m :: * -> *). (Marshal a, MonadPop m) => m a
pop
  {-# INLINABLE pop #-}

instance Marshal TL.Text where
  push :: Text -> m ()
push = String -> m ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push (String -> m ()) -> (Text -> String) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack
  {-# INLINABLE push #-}
  pop :: m Text
pop = String -> Text
TL.pack (String -> Text) -> m String -> m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
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 :: K1 i a a -> m ()
gpush (K1 x :: a
x) = a -> m ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push a
x
  {-# INLINABLE gpush #-}
  gpop :: 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 :: (:*:) f g a -> m ()
gpush (a :: f a
a :*: b :: 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 :: 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 :: M1 i c a a -> m ()
gpush (M1 x :: a a
x) = a a -> m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadPush m) =>
f a -> m ()
gpush a a
x
  {-# INLINABLE gpush #-}
  gpop :: 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 #-}