{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE DerivingVia, TypeFamilies #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, DataKinds #-}
{-# LANGUAGE UndecidableInstances, DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables, TypeOperators #-}

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

import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Except
import Control.Monad.RWS
import GHC.Generics
import Foreign.Ptr
import Data.Int
import qualified Language.Souffle.Internal as Internal
import qualified Language.Souffle.Internal.Constraints as C


type Tuple = Ptr Internal.Tuple

-- | A monad transformer, used solely for marshalling and unmarshalling
--   between Haskell and Souffle Datalog.
newtype MarshalT m a = MarshalT (ReaderT Tuple m a)
  deriving ( a -> MarshalT m b -> MarshalT m a
(a -> b) -> MarshalT m a -> MarshalT m b
(forall a b. (a -> b) -> MarshalT m a -> MarshalT m b)
-> (forall a b. a -> MarshalT m b -> MarshalT m a)
-> Functor (MarshalT m)
forall a b. a -> MarshalT m b -> MarshalT m a
forall a b. (a -> b) -> MarshalT m a -> MarshalT m b
forall (m :: * -> *) a b.
Functor m =>
a -> MarshalT m b -> MarshalT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MarshalT m a -> MarshalT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> MarshalT m b -> MarshalT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> MarshalT m b -> MarshalT m a
fmap :: (a -> b) -> MarshalT m a -> MarshalT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MarshalT m a -> MarshalT m b
Functor, Functor (MarshalT m)
a -> MarshalT m a
Functor (MarshalT m) =>
(forall a. a -> MarshalT m a)
-> (forall a b.
    MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b)
-> (forall a b c.
    (a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c)
-> (forall a b. MarshalT m a -> MarshalT m b -> MarshalT m b)
-> (forall a b. MarshalT m a -> MarshalT m b -> MarshalT m a)
-> Applicative (MarshalT m)
MarshalT m a -> MarshalT m b -> MarshalT m b
MarshalT m a -> MarshalT m b -> MarshalT m a
MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b
(a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c
forall a. a -> MarshalT m a
forall a b. MarshalT m a -> MarshalT m b -> MarshalT m a
forall a b. MarshalT m a -> MarshalT m b -> MarshalT m b
forall a b. MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b
forall a b c.
(a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (MarshalT m)
forall (m :: * -> *) a. Applicative m => a -> MarshalT m a
forall (m :: * -> *) a b.
Applicative m =>
MarshalT m a -> MarshalT m b -> MarshalT m a
forall (m :: * -> *) a b.
Applicative m =>
MarshalT m a -> MarshalT m b -> MarshalT m b
forall (m :: * -> *) a b.
Applicative m =>
MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c
<* :: MarshalT m a -> MarshalT m b -> MarshalT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
MarshalT m a -> MarshalT m b -> MarshalT m a
*> :: MarshalT m a -> MarshalT m b -> MarshalT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
MarshalT m a -> MarshalT m b -> MarshalT m b
liftA2 :: (a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> MarshalT m a -> MarshalT m b -> MarshalT m c
<*> :: MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
MarshalT m (a -> b) -> MarshalT m a -> MarshalT m b
pure :: a -> MarshalT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> MarshalT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (MarshalT m)
Applicative, Applicative (MarshalT m)
a -> MarshalT m a
Applicative (MarshalT m) =>
(forall a b. MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b)
-> (forall a b. MarshalT m a -> MarshalT m b -> MarshalT m b)
-> (forall a. a -> MarshalT m a)
-> Monad (MarshalT m)
MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b
MarshalT m a -> MarshalT m b -> MarshalT m b
forall a. a -> MarshalT m a
forall a b. MarshalT m a -> MarshalT m b -> MarshalT m b
forall a b. MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b
forall (m :: * -> *). Monad m => Applicative (MarshalT m)
forall (m :: * -> *) a. Monad m => a -> MarshalT m a
forall (m :: * -> *) a b.
Monad m =>
MarshalT m a -> MarshalT m b -> MarshalT m b
forall (m :: * -> *) a b.
Monad m =>
MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> MarshalT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> MarshalT m a
>> :: MarshalT m a -> MarshalT m b -> MarshalT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
MarshalT m a -> MarshalT m b -> MarshalT m b
>>= :: MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
MarshalT m a -> (a -> MarshalT m b) -> MarshalT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (MarshalT m)
Monad
           , Monad (MarshalT m)
Monad (MarshalT m) =>
(forall a. IO a -> MarshalT m a) -> MonadIO (MarshalT m)
IO a -> MarshalT m a
forall a. IO a -> MarshalT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (MarshalT m)
forall (m :: * -> *) a. MonadIO m => IO a -> MarshalT m a
liftIO :: IO a -> MarshalT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> MarshalT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (MarshalT m)
MonadIO, MonadReader Tuple, MonadWriter w
           , MonadState s, MonadRWS Tuple w s, MonadError e )
  via ( ReaderT Tuple m )
  deriving m a -> MarshalT m a
(forall (m :: * -> *) a. Monad m => m a -> MarshalT m a)
-> MonadTrans MarshalT
forall (m :: * -> *) a. Monad m => m a -> MarshalT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> MarshalT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> MarshalT m a
MonadTrans via (ReaderT Tuple)

-- | Execute the monad transformer and return the result.
--   The tuple that is passed in will be used to marshal the data back and forth.
runMarshalT :: MarshalT m a -> Tuple -> m a
runMarshalT :: MarshalT m a -> Tuple -> m a
runMarshalT (MarshalT m :: ReaderT Tuple m a
m) = ReaderT Tuple m a -> Tuple -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Tuple m a
m
{-# INLINABLE runMarshalT #-}


{- | 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. The programmer needs to make sure that the
marshalling 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 :: MonadIO m => a -> MarshalT m ()
  -- | Unmarshals a value from the datalog side.
  pop :: MonadIO m => MarshalT m a

  default push :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadIO m)
               => a -> MarshalT m ()
  default pop :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadIO m)
              => MarshalT m a
  push a :: a
a = Rep a Any -> MarshalT m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
f a -> MarshalT 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) -> MarshalT m (Rep a Any) -> MarshalT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MarshalT m (Rep a Any)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
MarshalT m (f a)
gpop
  {-# INLINABLE pop #-}

instance Marshal Int32 where
  push :: Int32 -> MarshalT m ()
push int :: Int32
int = do
    Tuple
tuple <- MarshalT m Tuple
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> MarshalT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MarshalT m ()) -> IO () -> MarshalT m ()
forall a b. (a -> b) -> a -> b
$ Tuple -> Int32 -> IO ()
Internal.tuplePushInt Tuple
tuple Int32
int
  {-# INLINABLE push #-}
  pop :: MarshalT m Int32
pop = do
    Tuple
tuple <- MarshalT m Tuple
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Int32 -> MarshalT m Int32
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int32 -> MarshalT m Int32) -> IO Int32 -> MarshalT m Int32
forall a b. (a -> b) -> a -> b
$ Tuple -> IO Int32
Internal.tuplePopInt Tuple
tuple
  {-# INLINABLE pop #-}

instance Marshal String where
  push :: String -> MarshalT m ()
push str :: String
str = do
    Tuple
tuple <- MarshalT m Tuple
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO () -> MarshalT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MarshalT m ()) -> IO () -> MarshalT m ()
forall a b. (a -> b) -> a -> b
$ Tuple -> String -> IO ()
Internal.tuplePushString Tuple
tuple String
str
  {-# INLINABLE push #-}
  pop :: MarshalT m String
pop = do
    Tuple
tuple <- MarshalT m Tuple
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO String -> MarshalT m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> MarshalT m String) -> IO String -> MarshalT m String
forall a b. (a -> b) -> a -> b
$ Tuple -> IO String
Internal.tuplePopString Tuple
tuple
  {-# INLINABLE pop #-}


class GMarshal f where
  gpush :: MonadIO m => f a -> MarshalT m ()
  gpop :: MonadIO m => MarshalT m (f a)

instance Marshal a => GMarshal (K1 i a) where
  gpush :: K1 i a a -> MarshalT m ()
gpush (K1 x :: a
x) = a -> MarshalT m ()
forall a (m :: * -> *).
(Marshal a, MonadIO m) =>
a -> MarshalT m ()
push a
x
  {-# INLINABLE gpush #-}
  gpop :: MarshalT 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) -> MarshalT m a -> MarshalT m (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MarshalT m a
forall a (m :: * -> *). (Marshal a, MonadIO m) => MarshalT m a
pop
  {-# INLINABLE gpop #-}

instance (GMarshal f, GMarshal g) => GMarshal (f :*: g) where
  gpush :: (:*:) f g a -> MarshalT m ()
gpush (a :: f a
a :*: b :: g a
b) = do
    f a -> MarshalT m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
f a -> MarshalT m ()
gpush f a
a
    g a -> MarshalT m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
f a -> MarshalT m ()
gpush g a
b
  {-# INLINABLE gpush #-}
  gpop :: MarshalT 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)
-> MarshalT m (f a) -> MarshalT m (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MarshalT m (f a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
MarshalT m (f a)
gpop MarshalT m (g a -> (:*:) f g a)
-> MarshalT m (g a) -> MarshalT m ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> MarshalT m (g a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
MarshalT m (f a)
gpop
  {-# INLINABLE gpop #-}

instance GMarshal a => GMarshal (M1 i c a) where
  gpush :: M1 i c a a -> MarshalT m ()
gpush (M1 x :: a a
x) = a a -> MarshalT m ()
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
f a -> MarshalT m ()
gpush a a
x
  {-# INLINABLE gpush #-}
  gpop :: MarshalT 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) -> MarshalT m (a a) -> MarshalT m (M1 i c a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MarshalT m (a a)
forall (f :: * -> *) (m :: * -> *) a.
(GMarshal f, MonadIO m) =>
MarshalT m (f a)
gpop
  {-# INLINABLE gpop #-}