souffle-haskell 0.2.2 → 0.2.3

raw patch · 5 files changed

+98/−140 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• lib/Language/Souffle/Compiled.hs +27/−37
• lib/Language/Souffle/Interpreted.hs +24/−30
• lib/Language/Souffle/Marshal.hs +39/−67
• souffle-haskell.cabal +2/−6

@@ -4,6 +4,12 @@ All notable changes to this project (as seen by library users) will be documented in this file. The CHANGELOG is available on [Github](https://github.com/luc-tielen/souffle-haskell.git/CHANGELOG.md). +## [0.2.2] - 2020-05-21+### Changed++- Optimize performance when marshalling and unmarshalling facts.++ ## [0.2.2] - 2020-04-30 ### Changed 

@@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE TypeFamilies, TypeOperators, DerivingVia, InstanceSigs, BangPatterns #-}-{-# LANGUAGE DataKinds, FlexibleContexts #-}+{-# LANGUAGE TypeFamilies, DerivingVia, InstanceSigs, BangPatterns #-}  -- | This module provides an implementation for the typeclasses defined in --   "Language.Souffle.Class".@@ -50,46 +49,37 @@  type Tuple = Ptr Internal.Tuple --- | A monad transformer, used solely for marshalling and unmarshalling+-- | A monad used solely for marshalling and unmarshalling --   between Haskell and Souffle Datalog.-newtype MarshalT m a = MarshalT (ReaderT Tuple m a)-  deriving ( Functor, Applicative, Monad-           , MonadIO, MonadReader Tuple, MonadWriter w-           , MonadState s, MonadRWS Tuple w s, MonadError e )-  via ( ReaderT Tuple m )-  deriving MonadTrans via (ReaderT Tuple)+newtype CMarshal a = CMarshal (ReaderT Tuple IO a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadReader Tuple)+  via ( ReaderT Tuple IO ) -runM :: Monad m => MarshalT m a -> Tuple -> m a-runM (MarshalT m) = runReaderT m+runM :: CMarshal a -> Tuple -> IO a+runM (CMarshal m) = runReaderT m {-# INLINABLE runM #-} --- | Execute the monad transformer and return the result.---   The tuple that is passed in will be used to marshal the data back and forth.-runPushT :: MonadIO m => MarshalM PushF a -> Tuple -> m a-runPushT = runM . interpret pushAlgM where-  pushAlgM (PushInt int v) = do+instance MonadPush CMarshal where+  pushInt int = do     tuple <- ask     liftIO $ Internal.tuplePushInt tuple int-    pure v-  pushAlgM (PushStr str v) = do+  {-# INLINABLE pushInt #-}++  pushString str = do     tuple <- ask     liftIO $ Internal.tuplePushString tuple str-    pure v-{-# INLINABLE runPushT #-}+  {-# INLINABLE pushString #-} --- | Execute the monad transformer and return the result.---   The tuple that is passed in will be used to marshal the data back and forth.-runPopT :: MonadIO m => MarshalM PopF a -> Tuple -> m a-runPopT = runM . interpret popAlgM where-  popAlgM (PopStr f) = MarshalT $ do+instance MonadPop CMarshal where+  popInt = do     tuple <- ask-    str   <- liftIO $ Internal.tuplePopString tuple-    pure $ f str-  popAlgM (PopInt f) = MarshalT $ do+    liftIO $ Internal.tuplePopInt tuple+  {-# INLINABLE popInt #-}++  popString = do     tuple <- ask-    int   <- liftIO $ Internal.tuplePopInt tuple-    pure $ f int-{-# INLINABLE runPopT #-}+    liftIO $ Internal.tuplePopString tuple+  {-# INLINABLE popString #-}  class Collect c where   collect :: Marshal a => Int -> ForeignPtr Internal.RelationIterator -> IO (c a)@@ -100,7 +90,7 @@       go idx count acc _ | idx == count = pure acc       go idx count !acc !it = do         tuple <- Internal.relationIteratorNext it-        result <- runPopT pop tuple+        result <- runM pop tuple         go (idx + 1) count (result : acc) it   {-# INLINABLE collect #-} @@ -112,7 +102,7 @@       go vec idx count _ | idx == count = V.unsafeFreeze vec       go vec idx count it = do         tuple <- Internal.relationIteratorNext it-        result <- runPopT pop tuple+        result <- runM pop tuple         MV.unsafeWrite vec idx result         go vec (idx + 1) count it   {-# INLINABLE collect #-}@@ -166,19 +156,19 @@    findFact :: forall a prog. (Fact a, ContainsFact prog a)            => Handle prog -> a -> SouffleM (Maybe a)-  findFact (Handle prog) a = SouffleM $ do+  findFact (Handle prog) fact = SouffleM $ do     let relationName = factName (Proxy :: Proxy a)     relation <- Internal.getRelation prog relationName     tuple <- Internal.allocTuple relation-    withForeignPtr tuple $ runPushT (push a)+    withForeignPtr tuple $ runM (push fact)     found <- Internal.containsTuple relation tuple-    pure $ if found then Just a else Nothing+    pure $ if found then Just fact else Nothing   {-# INLINABLE findFact #-}  addFact' :: Fact a => Ptr Internal.Relation -> a -> IO () addFact' relation fact = do   tuple <- Internal.allocTuple relation-  withForeignPtr tuple $ runPushT (push fact)+  withForeignPtr tuple $ runM (push fact)   Internal.addTuple relation tuple {-# INLINABLE addFact' #-} 

@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE DataKinds, FlexibleContexts, TypeFamilies, DerivingVia, InstanceSigs #-}+{-# LANGUAGE TypeFamilies, DerivingVia, InstanceSigs #-}  -- | This module provides an implementation for the `MonadSouffle` typeclass --   defined in "Language.Souffle.Class".@@ -118,40 +118,34 @@   }  newtype IMarshal a = IMarshal (State [String] a)-  deriving-    ( Functor-    , Applicative-    , Monad-    , MonadState [String]-    )+  deriving (Functor, Applicative, Monad, MonadState [String])   via (State [String]) -popMarshalT :: MarshalM PopF a -> [String] -> a-popMarshalT = runM . interpret popAlgM where-  runM (IMarshal m) = evalState m-  popAlgM (PopStr f) = do-    str <- state (\case-              [] -> error "Empty fact stack"-              (h:t) -> (h, t))-    pure $ f str-  popAlgM (PopInt f) = do-    int <- state (\case-              [] -> error "Empty fact stack"-              (h:t) -> (read h, t))-    pure $ f int+instance MonadPush IMarshal where+  pushInt int = modify (show int:)+  {-# INLINABLE pushInt #-}++  pushString str = modify (str:)+  {-# INLINABLE pushString #-}++instance MonadPop IMarshal where+  popInt = state $ \case+    [] -> error "Empty fact stack"+    (h:t) -> (read h, t)+  {-# INLINABLE popInt #-}++  popString = state $ \case+    [] -> error "Empty fact stack"+    (h:t) -> (h, t)+  {-# INLINABLE popString #-}++popMarshalT :: IMarshal a -> [String] -> a+popMarshalT (IMarshal m) = evalState m {-# INLINABLE popMarshalT #-} -pushMarshalT :: MarshalM PushF a -> [String]-pushMarshalT = runM . interpret pushAlgM where-  runM (IMarshal m) = reverse $ execState m []-  pushAlgM (PushInt i v) = do-    modify (show i:)-    pure v-  pushAlgM (PushStr s v) = do-    modify (s:)-    pure v+pushMarshalT :: IMarshal a -> [String]+pushMarshalT (IMarshal m) = reverse $ execState m [] {-# INLINABLE pushMarshalT #-}-  class Collect c where   collect :: Marshal a => FilePath -> IO (c a)

@@ -1,18 +1,15 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE FlexibleInstances, FlexibleContexts, DeriveFunctor #-}-{-# LANGUAGE DefaultSignatures, TypeOperators, RankNTypes #-}+{-# 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---   and 'MarshalM' monad.+--   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(..)-  , PushF(..)-  , PopF(..)-  , MarshalM-  , interpret+  , MonadPush(..)+  , MonadPop(..)   ) where  import GHC.Generics@@ -21,56 +18,29 @@ 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 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 Functor---- NOTE: Free is reimplemented here to avoid pulling in quite a few---       dependencies and since we only need 2 functions+{- | A typeclass for serializing primitive values from Haskell to Datalog. --- | The monad used for serializing and deserializing of values that---   implement the `Marshal` typeclass.-data MarshalM f a-  = Pure a-  | Free (f (MarshalM f a))-  deriving Functor+This typeclass is only used internally and subject to change. -instance Functor f => Applicative (MarshalM f) where-  pure = Pure-  {-# INLINABLE pure #-}-  Pure f <*> Pure a = Pure $ f a-  Pure f <*> Free fa = f <$> Free fa-  Free fa <*> m = Free $ fmap (<*> m) fa-  {-# INLINABLE (<*>) #-}+See also: 'MonadPop', 'Marshal'.+-}+class Monad m => MonadPush m where+  -- | Marshals an integer to the datalog side.+  pushInt :: Int32 -> m ()+  -- | Marshals a string to the datalog side.+  pushString :: String -> m () -instance Functor f => Monad (MarshalM f) where-  Pure a >>= f = f a-  Free fa >>= f = Free $ fmap (>>= f) fa-  {-# INLINABLE (>>=) #-}+{- | A typeclass for serializing primitive values from Datalog to Haskell. -liftF :: Functor f => f a -> MarshalM f a-liftF action = Free $ fmap pure action-{-# INLINABLE liftF #-}+This typeclass is only used internally and subject to change. --- | 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 f = \case-  Pure a -> pure a-  Free fa -> f fa >>= interpret f-{-# INLINABLE interpret #-}+See also: 'MonadPush', 'Marshal'.+-}+class Monad m => MonadPop m where+  -- | Unmarshals an integer from the datalog side.+  popInt :: m Int32+  -- | 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.@@ -93,46 +63,48 @@ -} class Marshal a where   -- | Marshals a value to the datalog side.-  push :: a -> MarshalM PushF ()+  push :: MonadPush m => a -> m ()   -- | Unmarshals a value from the datalog side.-  pop :: MarshalM PopF a+  pop :: MonadPop m => m 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+  default push+    :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadPush m)+    => a -> m ()+  default pop+    :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadPop m)+    => m a   push a = gpush (from a)   {-# INLINABLE push #-}   pop = to <$> gpop   {-# INLINABLE pop #-}  instance Marshal Int32 where-  push int = liftF (PushInt int ())+  push = pushInt   {-# INLINABLE push #-}-  pop  = liftF (PopInt id)+  pop = popInt   {-# INLINABLE pop #-}  instance Marshal String where-  push str = liftF (PushStr str ())+  push = pushString   {-# INLINABLE push #-}-  pop  = liftF (PopStr id)+  pop = popString   {-# INLINABLE pop #-}  instance Marshal T.Text where   push = push . T.unpack   {-# INLINABLE push #-}-  pop  = T.pack <$> pop+  pop = T.pack <$> pop   {-# INLINABLE pop #-}  instance Marshal TL.Text where   push = push . TL.unpack   {-# INLINABLE push #-}-  pop  = TL.pack <$> pop+  pop = TL.pack <$> pop   {-# INLINABLE pop #-}  class GMarshal f where-  gpush :: f a -> MarshalM PushF ()-  gpop  :: MarshalM PopF (f a)+  gpush :: MonadPush m => f a -> m ()+  gpop  :: MonadPop m => m (f a)  instance Marshal a => GMarshal (K1 i a) where   gpush (K1 x) = push x

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 25ea3b610616a6824b69546c184f2e1fd2cdcb36e648715c6166441f27013011+-- hash: edee24fd0c26174211bf0f36205df0d361d3a2d6d55987259a09e4b4a80bd62d  name:           souffle-haskell-version:        0.2.2+version:        0.2.3 synopsis:       Souffle Datalog bindings for Haskell description:    Souffle Datalog bindings for Haskell. category:       Logic Programming, Foreign Binding, Bindings@@ -68,8 +68,6 @@     extra-libraries:         stdc++   default-language: Haskell2010-  build-tools:-      souffle  test-suite souffle-haskell-test   type: exitcode-stdio-1.0@@ -84,8 +82,6 @@   default-extensions: OverloadedStrings LambdaCase ScopedTypeVariables   ghc-options: -Wall -Weverything -Wno-safe -Wno-unsafe -Wno-implicit-prelude -Wno-missed-specializations -Wno-all-missed-specializations -Wno-missing-import-lists -Wno-type-defaults -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-deriving-strategies -optP-Wno-nonportable-include-path -fhide-source-paths -fno-show-valid-hole-fits -fno-sort-valid-hole-fits   cpp-options: -std=c++17 -D__EMBEDDED_SOUFFLE__-  build-tools:-      souffle   build-depends:       base >=4.12 && <5     , deepseq >=1.4.4 && <2