{-# 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 #-}