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

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

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


-- | A data type used for deserializing a `Marshal`-able value
--   from Souffle to Haskell, only used internally.
data PopF a
  = PopInt (Int32 -> a)
  | PopStr (String -> a)
  deriving a -> PopF b -> PopF a
(a -> b) -> PopF a -> PopF b
(forall a b. (a -> b) -> PopF a -> PopF b)
-> (forall a b. a -> PopF b -> PopF a) -> Functor PopF
forall a b. a -> PopF b -> PopF a
forall a b. (a -> b) -> PopF a -> PopF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PopF b -> PopF a
$c<$ :: forall a b. a -> PopF b -> PopF a
fmap :: (a -> b) -> PopF a -> PopF b
$cfmap :: forall a b. (a -> b) -> PopF a -> PopF b
Functor

-- | A data type used for serializing a `Marshal`-able value
--   from Haskell to Souffle, only used internally.
data PushF a
  = PushInt Int32 a
  | PushStr String a
  deriving a -> PushF b -> PushF a
(a -> b) -> PushF a -> PushF b
(forall a b. (a -> b) -> PushF a -> PushF b)
-> (forall a b. a -> PushF b -> PushF a) -> Functor PushF
forall a b. a -> PushF b -> PushF a
forall a b. (a -> b) -> PushF a -> PushF b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PushF b -> PushF a
$c<$ :: forall a b. a -> PushF b -> PushF a
fmap :: (a -> b) -> PushF a -> PushF b
$cfmap :: forall a b. (a -> b) -> PushF a -> PushF b
Functor

-- | The monad used for serializing and deserializing of values that
--   implement the `Marshal` typeclass.
type MarshalM = Free

-- | Helper function for interpreting the actual (de-)serialization of values.
--   This allows both the compiled and interpreted variant to handle
--   (de-)serialization in their own way.
interpret :: Monad m => (forall x. f x -> m x) -> MarshalM f a -> m a
interpret :: (forall x. f x -> m x) -> MarshalM f a -> m a
interpret = (forall x. f x -> m x) -> MarshalM f a -> m a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> Free f a -> m a
foldFree
{-# INLINABLE interpret #-}

{- | 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 :: a -> MarshalM PushF ()
  -- | Unmarshals a value from the datalog side.
  pop :: MarshalM PopF a

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

instance Marshal Int32 where
  push :: Int32 -> MarshalM PushF ()
push int :: Int32
int = PushF () -> MarshalM PushF ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (Int32 -> () -> PushF ()
forall a. Int32 -> a -> PushF a
PushInt Int32
int ())
  {-# INLINABLE push #-}
  pop :: MarshalM PopF Int32
pop  = PopF Int32 -> MarshalM PopF Int32
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF ((Int32 -> Int32) -> PopF Int32
forall a. (Int32 -> a) -> PopF a
PopInt Int32 -> Int32
forall a. a -> a
id)
  {-# INLINABLE pop #-}

instance Marshal String where
  push :: String -> MarshalM PushF ()
push str :: String
str = PushF () -> MarshalM PushF ()
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF (String -> () -> PushF ()
forall a. String -> a -> PushF a
PushStr String
str ())
  {-# INLINABLE push #-}
  pop :: MarshalM PopF String
pop  = PopF String -> MarshalM PopF String
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, MonadFree f m) =>
f a -> m a
liftF ((String -> String) -> PopF String
forall a. (String -> a) -> PopF a
PopStr String -> String
forall a. a -> a
id)
  {-# INLINABLE pop #-}

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

instance Marshal TL.Text where
  push :: Text -> MarshalM PushF ()
push = String -> MarshalM PushF ()
forall a. Marshal a => a -> MarshalM PushF ()
push (String -> MarshalM PushF ())
-> (Text -> String) -> Text -> MarshalM PushF ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
TL.unpack
  {-# INLINABLE push #-}
  pop :: MarshalM PopF Text
pop  = String -> Text
TL.pack (String -> Text) -> MarshalM PopF String -> MarshalM PopF Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MarshalM PopF String
forall a. Marshal a => MarshalM PopF a
pop
  {-# INLINABLE pop #-}

class GMarshal f where
  gpush :: f a -> MarshalM PushF ()
  gpop  :: MarshalM PopF (f a)

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

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

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