souffle-haskell 1.1.0 → 2.0.0

raw patch · 16 files changed

+2642/−275 lines, 16 filesdep +neat-interpolationPVP ok

version bump matches the API change (PVP)

Dependencies added: neat-interpolation

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−0
• README.md +6/−10
• lib/Language/Souffle/Class.hs +80/−39
• lib/Language/Souffle/Compiled.hs +27/−15
• lib/Language/Souffle/Experimental.hs +1098/−0
• lib/Language/Souffle/Internal/Constraints.hs +3/−5
• lib/Language/Souffle/Interpreted.hs +70/−59
• lib/Language/Souffle/Marshal.hs +2/−2
• scripts/import_souffle_headers.hs +53/−17
• souffle-haskell.cabal +12/−2
• tests/Test/Language/Souffle/CompiledSpec.hs +32/−40
• tests/Test/Language/Souffle/Experimental/Fixtures.hs +31/−0
• tests/Test/Language/Souffle/Experimental/FixturesCompiled.hs +21/−0
• tests/Test/Language/Souffle/ExperimentalSpec.hs +1117/−0
• tests/Test/Language/Souffle/InterpretedSpec.hs +43/−70
• tests/Test/Language/Souffle/MarshalSpec.hs +20/−16

@@ -3,6 +3,33 @@ 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). +## [2.0.0] - 2020-08-23++### Added++- The `Fact` typeclass now also requires you to specify the `FactDirection`.+  This prevents inconsistent and buggy behavior when trying to use a fact in+  an invalid way (e.g. trying to add an output-only fact).+- DSL for creating Soufflé programs directly from Haskell.+  See the docs of `Language.Souffle.Experimental` for more information.++### Changed++- souffle-haskell now supports Soufflé version 2.0.1.+- `getFacts`, `findFact`, `addFact` and `addFacts` now have stricter+  constraints in their type signatures to prevent invalid usage of facts.+- `runSouffle` for both compiled and interpreted mode and `runSouffleWith`+  for interpreted mode have updated type signatures to be able to+  automatically cleanup temporary files created while interacting with Souffle.++### Removed++- `init` function for both compiled and interpreted mode. Initialization is+  now handled by the `runSouffle*` functions. This change makes automatic+  cleanup of created files possible and prevents double initialization of+  Souffle programs.+- `cleanup` function for interpreted mode, this is handled automatically now.+ ## [1.1.0] - 2020-07-26  ### Added

@@ -77,9 +77,11 @@ -- By making a data type an instance of Fact, we give Haskell the -- necessary information to bind to the datalog fact. instance Souffle.Fact Edge where+  type FactDirection Edge = 'Souffle.Input   factName = const "edge"  instance Souffle.Fact Reachable where+  type FactDirection Reachable = 'Souffle.Output   factName = const "reachable"  -- For simple product types, we can automatically generate the@@ -89,8 +91,7 @@   main :: IO ()-main = Souffle.runSouffle $ do-  maybeProgram <- Souffle.init Path  -- Initializes the Souffle program.+main = Souffle.runSouffle Path $ \maybeProgram -> do  -- Initializes the Souffle program.   case maybeProgram of     Nothing -> liftIO $ putStrLn "Failed to load program."     Just prog -> do@@ -182,12 +183,8 @@ change your Datalog code). However because the Souffle code is interpreted, it can't offer the same speed as in compiled mode. -The main differences with compiled mode are the following:--1. You need to import `Language.Souffle.Interpreted`-2. You need to call `Souffle.cleanup` after you no longer need the Souffle-   functionality. This will clean up the generated CSV fact files located in-   a temporary directory.+If you want to use interpreted Souffle, you need to import the+`Language.Souffle.Interpreted` module.  #### Interpreter configuration @@ -218,8 +215,7 @@ The main differences with interpreted mode are the following:  1. Compile the Datalog code with `souffle -g`.-2. Remove `Souffle.cleanup` if it is present in your code, compiled mode-   leaves no CSV artifacts.+2. Import `Language.Souffle.Compiled`  The [motivating example](#motivating-example) is a complete example for the compiled mode. 

@@ -14,9 +14,13 @@ --   This module also contains some helper type families for additional --   type safety and user-friendly error messages. module Language.Souffle.Class-  ( ContainsFact-  , Program(..)+  ( Program(..)   , Fact(..)+  , Marshal.Marshal(..)+  , Direction(..)+  , ContainsInputFact+  , ContainsOutputFact+  , ContainsFact   , MonadSouffle(..)   , MonadSouffleFileIO(..)   ) where@@ -35,8 +39,46 @@ import Type.Errors.Pretty  --- | A helper type family for checking if a specific Souffle `Program` contains a certain `Fact`.---   This will generate a user-friendly type error if this is not the case.+-- | A helper type family for checking if a specific Souffle `Program` contains+--   a certain `Fact`. Additionally, it also checks if the fact is marked as+--   either `Input` or `InputOutput`. This constraint will generate a+--   user-friendly type error if these conditions are not met.+type family ContainsInputFact prog fact :: Constraint where+  ContainsInputFact prog fact = (ContainsFact prog fact, IsInput fact (FactDirection fact))++-- | A helper type family for checking if a specific Souffle `Program` contains+--   a certain `Fact`. Additionally, it also checks if the fact is marked as+--   either `Output` or `InputOutput`. This constraint will generate a+--   user-friendly type error if these conditions are not met.+type family ContainsOutputFact prog fact :: Constraint where+  ContainsOutputFact prog fact = (ContainsFact prog fact, IsOutput fact (FactDirection fact))++type family IsInput (fact :: Type) (dir :: Direction) :: Constraint where+  IsInput _ 'Input = ()+  IsInput _ 'InputOutput = ()+  IsInput fact dir = TypeError+    ( "You tried to use an " <> FormatDirection dir <> " fact of type " <> fact <> " as an input."+    % "Possible solution: change the FactDirection of " <> fact+      <> " to either 'Input' or 'InputOutput'."+    )++type family IsOutput (fact :: Type) (dir :: Direction) :: Constraint where+  IsOutput _ 'Output = ()+  IsOutput _ 'InputOutput = ()+  IsOutput fact dir = TypeError+    ( "You tried to use an " <> FormatDirection dir <> " fact of type " <> fact <> " as an output."+    % "Possible solution: change the FactDirection of " <> fact+      <> " to either 'Output' or 'InputOutput'."+    )++type family FormatDirection (dir :: Direction) where+  FormatDirection 'Output = "output"+  FormatDirection 'Input = "input"+  FormatDirection 'Internal = "internal"++-- | A helper type family for checking if a specific Souffle `Program` contains+--   a certain `Fact`. This constraint will generate a user-friendly type error+--   if this is not the case. type family ContainsFact prog fact :: Constraint where   ContainsFact prog fact =     CheckContains prog (ProgramFacts prog) fact@@ -71,46 +113,55 @@    -- | Function for obtaining the name of a Datalog program.   --   This has to be the same as the name of the .dl file (minus the extension).-  ---  -- It uses a 'Proxy' to select the correct instance.-  programName :: Proxy a -> String+  programName :: a -> String  -- | A typeclass for data types representing a fact in datalog.+--+-- Example usage:+--+-- @+-- instance Fact Edge where+--   type FactDirection Edge = 'Input+--   factName = const "edge"+-- @ class Marshal.Marshal a => Fact a where+  -- | The direction or "mode" a fact can be used in.+  --   This is used to perform compile-time checks that a fact is only used+  --   in valid situations. For more information, see the 'Direction' type.+  type FactDirection a :: Direction+   -- | Function for obtaining the name of a fact   --   (has to be the same as described in the Datalog program).   --   -- It uses a 'Proxy' to select the correct instance.-  ---  -- Example usage:-  ---  -- @-  -- instance Fact Edge where-  --   factName = const "edge"-  -- @   factName :: Proxy a -> String +-- | A datatype describing which operations a certain fact supports.+--   The direction is from the datalog perspective, so that it+--   aligns with ".decl" statements in Souffle.+data Direction+  = Input+  -- ^ Fact can only be stored in Datalog (using `addFact`/`addFacts`).+  | Output+  -- ^ Fact can only be read from Datalog (using `getFacts`/`findFact`).+  | InputOutput+  -- ^ Fact supports both reading from / writing to Datalog.+  | Internal+  -- ^ Supports neither reading from / writing to Datalog. This is used for+  --   facts that are only visible inside Datalog itself.  -- | A mtl-style typeclass for Souffle-related actions. class Monad m => MonadSouffle m where   -- | Represents a handle for interacting with a Souffle program.-  --   See also `init`, which returns a handle of this type.+  --+  --   The handle is used in all other functions of this typeclass to perform+  --   Souffle-related actions.   type Handler m :: Type -> Type    -- | Helper associated type constraint that allows collecting facts from   --   Souffle in a list or vector. Only used internally.   type CollectFacts m (c :: Type -> Type) :: Constraint -  {- | Initializes a Souffle program.--     The action will return 'Nothing' if it failed to load the Souffle C++-     program or if it failed to find the Souffle interpreter (depending on-     compiled/interpreted variant).-     Otherwise it will return a handle that can be used in other functions-     in this module.-  -}-  init :: Program prog => prog -> m (Maybe (Handler m prog))-   -- | Runs the Souffle program.   run :: Handler m prog -> m () @@ -122,7 +173,7 @@    -- | Returns all facts of a program. This function makes use of type inference   --   to select the type of fact to return.-  getFacts :: (Fact a, ContainsFact prog a, CollectFacts m c)+  getFacts :: (Fact a, ContainsOutputFact prog a, CollectFacts m c)            => Handler m prog -> m (c a)    -- | Searches for a fact in a program.@@ -130,24 +181,22 @@   --   --   Conceptually equivalent to @List.find (== fact) \<$\> getFacts prog@,   --   but this operation can be implemented much faster.-  findFact :: (Fact a, ContainsFact prog a, Eq a)+  findFact :: (Fact a, ContainsOutputFact prog a, Eq a)            => Handler m prog -> a -> m (Maybe a)    -- | Adds a fact to the program.-  addFact :: (Fact a, ContainsFact prog a)+  addFact :: (Fact a, ContainsInputFact prog a)           => Handler m prog -> a -> m ()    -- | Adds multiple facts to the program. This function could be implemented   --   in terms of 'addFact', but this is done as a minor optimization.-  addFacts :: (Foldable t, Fact a, ContainsFact prog a)+  addFacts :: (Foldable t, Fact a, ContainsInputFact prog a)            => Handler m prog -> t a -> m ()  instance MonadSouffle m => MonadSouffle (ReaderT r m) where   type Handler (ReaderT r m) = Handler m   type CollectFacts (ReaderT r m) c = CollectFacts m c -  init = lift . init-  {-# INLINABLE init #-}   run = lift . run   {-# INLINABLE run #-}   setNumThreads prog = lift . setNumThreads prog@@ -167,8 +216,6 @@   type Handler (WriterT w m) = Handler m   type CollectFacts (WriterT w m) c = CollectFacts m c -  init = lift . init-  {-# INLINABLE init #-}   run = lift . run   {-# INLINABLE run #-}   setNumThreads prog = lift . setNumThreads prog@@ -188,8 +235,6 @@   type Handler (StateT s m) = Handler m   type CollectFacts (StateT s m) c = CollectFacts m c -  init = lift . init-  {-# INLINABLE init #-}   run = lift . run   {-# INLINABLE run #-}   setNumThreads prog = lift . setNumThreads prog@@ -209,8 +254,6 @@   type Handler (RWST r w s m) = Handler m   type CollectFacts (RWST r w s m) c = CollectFacts m c -  init = lift . init-  {-# INLINABLE init #-}   run = lift . run   {-# INLINABLE run #-}   setNumThreads prog = lift . setNumThreads prog@@ -230,8 +273,6 @@   type Handler (ExceptT e m) = Handler m   type CollectFacts (ExceptT e m) c = CollectFacts m c -  init = lift . init-  {-# INLINABLE init #-}   run = lift . run   {-# INLINABLE run #-}   setNumThreads prog = lift . setNumThreads prog

@@ -14,9 +14,13 @@   ( Program(..)   , Fact(..)   , Marshal(..)+  , Direction(..)+  , ContainsInputFact+  , ContainsOutputFact   , Handle   , SouffleM   , MonadSouffle(..)+  , MonadSouffleFileIO(..)   , runSouffle   ) where @@ -45,11 +49,26 @@ newtype Handle prog = Handle (ForeignPtr Internal.Souffle)  -- | A monad for executing Souffle-related actions in.-newtype SouffleM a-  = SouffleM-  { runSouffle :: IO a  -- ^ Returns the underlying IO action.-  } deriving ( Functor, Applicative, Monad, MonadIO ) via IO+newtype SouffleM a = SouffleM (IO a)+  deriving ( Functor, Applicative, Monad, MonadIO ) via IO +{- | Initializes and runs a Souffle program.++     The 2nd argument is passed in a handle after initialization of the+     Souffle program. The handle will contain 'Nothing' if it failed to+     load the Souffle C++ program. In the successful case it will contain+     a handle that can be used for performing Souffle related actions+     using the other functions in this module.+-}+runSouffle :: forall prog a. Program prog+           => prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a+runSouffle prog action =+  let progName = programName prog+      (SouffleM result) = do+        handle <- fmap Handle <$> liftIO (Internal.init progName)+        action handle+   in result+ type Tuple = Ptr Internal.Tuple  -- | A monad used solely for marshalling and unmarshalling@@ -153,13 +172,6 @@   type Handler SouffleM = Handle   type CollectFacts SouffleM c = Collect c -  init :: forall prog. Program prog-       => prog -> SouffleM (Maybe (Handle prog))-  init _ =-    let progName = programName (Proxy :: Proxy prog)-    in SouffleM $ fmap Handle <$> Internal.init progName-  {-# INLINABLE init #-}-   run (Handle prog) = SouffleM $ Internal.run prog   {-# INLINABLE run #-} @@ -171,7 +183,7 @@     SouffleM $ Internal.getNumThreads prog   {-# INLINABLE getNumThreads #-} -  addFact :: forall a prog. (Fact a, ContainsFact prog a)+  addFact :: forall a prog. (Fact a, ContainsInputFact prog a)           => Handle prog -> a -> SouffleM ()   addFact (Handle prog) fact = liftIO $ do     let relationName = factName (Proxy :: Proxy a)@@ -179,7 +191,7 @@     addFact' relation fact   {-# INLINABLE addFact #-} -  addFacts :: forall t a prog . (Foldable t, Fact a, ContainsFact prog a)+  addFacts :: forall t a prog . (Foldable t, Fact a, ContainsInputFact prog a)            => Handle prog -> t a -> SouffleM ()   addFacts (Handle prog) facts = liftIO $ do     let relationName = factName (Proxy :: Proxy a)@@ -187,7 +199,7 @@     traverse_ (addFact' relation) facts   {-# INLINABLE addFacts #-} -  getFacts :: forall a c prog. (Fact a, ContainsFact prog a, Collect c)+  getFacts :: forall a c prog. (Fact a, ContainsOutputFact prog a, Collect c)            => Handle prog -> SouffleM (c a)   getFacts (Handle prog) = SouffleM $ do     let relationName = factName (Proxy :: Proxy a)@@ -196,7 +208,7 @@     Internal.getRelationIterator relation >>= collect factCount   {-# INLINABLE getFacts #-} -  findFact :: forall a prog. (Fact a, ContainsFact prog a)+  findFact :: forall a prog. (Fact a, ContainsOutputFact prog a)            => Handle prog -> a -> SouffleM (Maybe a)   findFact (Handle prog) fact = SouffleM $ do     let relationName = factName (Proxy :: Proxy a)

@@ -0,0 +1,1098 @@+{-# LANGUAGE GADTs, RankNTypes, TypeFamilies, DataKinds, TypeOperators, ConstraintKinds #-}+{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses, FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, DerivingVia, ScopedTypeVariables #-}+{-# LANGUAGE PolyKinds #-}+{-# OPTIONS_GHC -Wno-redundant-constraints #-}++{-| This module provides an experimental DSL for generating Souffle Datalog code,+    directly from Haskell.++    The module is meant to be imported unqualified, unlike the rest of this+    library. This allows for a syntax that is very close to the corresponding+    Datalog syntax you would normally write.++    The functions and operators provided by this module follow a naming scheme:++    - If there is no clash with something imported via Prelude, the+      function or operator is named exactly the same as in Souffle.+    - If there is a clash for functions, an apostrophe is appended+      (e.g. "max" in Datalog is 'max'' in Haskell).+    - Most operators (besides those from the Num typeclass) start with a "."+      (e.g. '.^' is the "^"  operator in Datalog)++    The DSL makes heavy use of Haskell's typesystem to avoid+    many kinds of errors. This being said, not everything can be checked at+    compile-time (for example performing comparisons on ungrounded variables+    can't be checked). For this reason you should regularly write the+    Datalog code to a file while prototyping your algorithm and check it using+    the Souffle executable for errors.++    A large subset of the Souffle language is covered, with some exceptions+    such as "$", aggregates, ... There are no special functions for supporting+    components either, but this is automatically possible by making use of+    polymorphism in Haskell.++    Here's an example snippet of Haskell code that can generate Datalog code:++    @+    -- Assuming we have 2 types of facts named Edge and Reachable:+    data Edge = Edge String String+    data Reachable = Reachable String String++    program = do+      Predicate edge <- predicateFor \@Edge+      Predicate reachable <- predicateFor \@Reachable+      a <- var "a"+      b <- var "b"+      c <- var "c"+      reachable(a, b) |- edge(a, b)+      reachable(a, b) |- do+        edge(a, c)+        reachable(c, b)+    @++    When rendered to a file (using 'renderIO'), this generates the following+    Souffle code:++    @+    .decl edge(t1: symbol, t2: symbol)+    .input edge+    .decl reachable(t1: symbol, t2: symbol)+    .output reachable+    reachable(a, b) :-+      edge(a, b)+    reachable(a, b) :- do+      edge(a, c)+      reachable(c, b)+    @++    For more examples, take a look at the <https://github.com/luc-tielen/souffle-haskell/blob/2c24e1e169da269c45fc192ab5efd4ff2196114b/tests/Test/Language/Souffle/ExperimentalSpec.hs tests>.+-}+module Language.Souffle.Experimental+  ( -- * DSL-related types and functions+    -- ** Types+    Predicate(..)+  , Fragment+  , Tuple+  , DSL+  , Head+  , Body+  , Term+  , VarName+  , UsageContext(..)+  , Direction(..)+  , ToPredicate+  , FactMetadata(..)+  , Metadata(..)+  , StructureOpt(..)+  , InlineOpt(..)+  -- ** Basic building blocks+  , predicateFor+  , var+  , __+  , underscore+  , (|-)+  , (\/)+  , not'+  -- ** Souffle operators+  , (.<)+  , (.<=)+  , (.>)+  , (.>=)+  , (.=)+  , (.!=)+  , (.^)+  , (.%)+  , band+  , bor+  , bxor+  , lor+  , land+  -- ** Souffle functions+  , max'+  , min'+  , cat+  , contains+  , match+  , ord+  , strlen+  , substr+  , to_number+  , to_string+  -- * Functions for running a Datalog DSL fragment / AST directly.+  , runSouffleInterpretedWith+  , runSouffleInterpreted+  , embedProgram+  -- * Rendering functions+  , render+  , renderIO+  -- * Helper type families useful in some situations+  , Structure+  , NoVarsInAtom+  , SupportsArithmetic+  ) where++import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Writer+import Data.Int+import Data.Kind+import Data.List.NonEmpty (NonEmpty(..), toList)+import Data.Map ( Map )+import qualified Data.Map as Map+import Data.Maybe (fromMaybe, catMaybes, mapMaybe)+import Data.Proxy+import Data.String+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Data.Text.Lazy as TL+import Data.Word+import GHC.Generics+import GHC.TypeLits+import Language.Haskell.TH.Syntax (qRunIO, qAddForeignFilePath, Q, Dec, ForeignSrcLang(..))+import Language.Souffle.Class ( Program(..), Fact(..), ContainsFact, Direction(..) )+import Language.Souffle.Internal.Constraints (SimpleProduct)+import qualified Language.Souffle.Interpreted as I+import System.Directory+import System.FilePath+import System.IO.Temp+import System.Process+import Text.Printf (printf)+import Type.Errors.Pretty+++-- | A datatype that contains a function for generating Datalog AST fragments+--   that can be glued together using other functions in this module.+--+--   The rank-N type allows using the inner function in multiple places to+--   generate different parts of the AST. This is one of the key things+--   that allows writing Haskell code in a very smilar way to the Datalog code.+--+--   The inner function uses the 'Structure' of a type to compute what the+--   shape of the input tuple for the predicate should be. For example, if a+--   fact has a data constructor containing a Float and a String,+--   the resulting tuple will be of type ('Term' ctx Float, 'Term' ctx String).+--+--   Currently, only facts with up to 10 fields are supported. If you need more+--   fields, please file an issue on+--   <https://github.com/luc-tielen/souffle-haskell/issues Github>.+newtype Predicate a+  = Predicate (forall f ctx. Fragment f ctx => Tuple ctx (Structure a) -> f ctx ())++type VarMap = Map VarName Int++-- | The main monad in which Datalog AST fragments are combined together+--   using other functions in this module.+--+--   - The "prog" type variable is used for performing many compile time checks.+--     This variable is filled (automatically) with a type that implements the+--     'Program' typeclass.+--   - The "ctx" type variable is the context in which a DSL fragment is used.+--     For more information, see 'UsageContext'.+--   - The "a" type variable is the value contained inside+--     (just like other monads).+newtype DSL prog ctx a = DSL (StateT VarMap (Writer [AST]) a)+  deriving (Functor, Applicative, Monad, MonadWriter [AST], MonadState VarMap)+  via (StateT VarMap (Writer [AST]))++addDefinition :: AST -> DSL prog 'Definition ()+addDefinition dl = tell [dl]++-- | This function runs the DSL fragment directly using the souffle interpreter+--   executable.+--+--   It does this by saving the fragment to a temporary file right before+--   running the souffle interpreter. All created files are automatically+--   cleaned up after the souffle related actions have been executed. If this is+--   not your intended behavior, see 'runSouffleInterpretedWith' which allows+--   passing in different interpreter settings.+runSouffleInterpreted+  :: (MonadIO m, Program prog)+  => prog+  -> DSL prog 'Definition ()+  -> (Maybe (I.Handle prog) -> I.SouffleM a)+  -> m a+runSouffleInterpreted program dsl f = liftIO $ do+  tmpDir <- getCanonicalTemporaryDirectory+  souffleHsDir <- createTempDirectory tmpDir "souffle-haskell"+  defaultCfg <- I.defaultConfig+  let cfg = defaultCfg { I.cfgDatalogDir = souffleHsDir+                       , I.cfgFactDir = Just souffleHsDir+                       , I.cfgOutputDir = Just souffleHsDir+                       }+  runSouffleInterpretedWith cfg program dsl f <* removeDirectoryRecursive souffleHsDir++-- | This function runs the DSL fragment directly using the souffle interpreter+--   executable.+--+--   It does this by saving the fragment to a file in the directory specified by+--   the 'I.cfgDatalogDir' field in the interpreter settings. Depending on the+--   chosen settings, the fact and output files may not be automatically cleaned+--   up after running the souffle interpreter. See 'I.runSouffleWith' for more+--   information on automatic cleanup.+runSouffleInterpretedWith+  :: (MonadIO m, Program prog)+  => I.Config+  -> prog+  -> DSL prog 'Definition ()+  -> (Maybe (I.Handle prog) -> I.SouffleM a)+  -> m a+runSouffleInterpretedWith config program dsl f = liftIO $ do+  let progName = programName program+      datalogFile = I.cfgDatalogDir config </> progName <.> "dl"+  renderIO program datalogFile dsl+  I.runSouffleWith config program f++-- | Embeds a Datalog program from a DSL fragment directly in a Haskell file.+--+--   Note that due to TemplateHaskell staging restrictions, this function must+--   be used in a different module than the module where 'Program' and 'Fact'+--   instances are defined.+embedProgram :: Program prog => prog -> DSL prog 'Definition () -> Q [Dec]+embedProgram program dsl = do+  cppFile <- qRunIO $ do+    tmpDir <- getCanonicalTemporaryDirectory+    souffleHsDir <- createTempDirectory tmpDir "souffle-haskell"+    let progName = programName program+        datalogFile = souffleHsDir </> progName <.> "dl"+        cppFile = souffleHsDir </> progName <.> "cpp"+    renderIO program datalogFile dsl+    callCommand $ printf "souffle -g %s %s" cppFile datalogFile+    pure cppFile+  qAddForeignFilePath LangCxx cppFile+  pure []++runDSL :: Program prog => prog -> DSL prog 'Definition a -> DL+runDSL _ (DSL a) = Statements $ mapMaybe simplify $ execWriter (evalStateT a mempty) where+  simplify = \case+    Declare' name dir fields opts -> pure $ Declare name dir fields opts+    Rule' name terms body -> Rule name terms <$> simplify body+    Atom' name terms -> pure $ Atom name terms+    And' exprs -> case mapMaybe simplify exprs of+      [] -> Nothing+      exprs' -> pure $ foldl1 And exprs'+    Or' exprs -> case mapMaybe simplify exprs of+      [] -> Nothing+      exprs' -> pure $ foldl1 Or exprs'+    Not' expr -> Not <$> simplify expr+    Constrain' e -> pure $ Constrain e++-- | Generates a unique variable, using the name argument as a hint.+--+--   The type of the variable is determined the first predicate it is used in.+--   The 'NoVarsInAtom' constraint generates a user-friendly type error if the+--   generated variable is used inside a relation (which is not valid in+--   Datalog).+--+--   Note: If a variable is created but not used using this function, you will+--   get a compile-time error because it can't deduce the constraint.+var :: NoVarsInAtom ctx => VarName -> DSL prog ctx' (Term ctx ty)+var name = do+  count <- fromMaybe 0 <$> gets (Map.lookup name)+  modify $ Map.insert name (count + 1)+  let varName = if count == 0 then name else name <> "_" <> T.pack (show count)+  pure $ VarTerm varName++-- | Data type representing the head of a relation+--   (the part before ":-" in a Datalog relation).+--+--   - The "ctx" type variable is the context in which this type is used.+--     For this type, this will always be 'Relation'. The variable is there to+--     perform some compile-time checks.+--   - The "unused" type variable is unused and only there so the type has the+--     same kind as 'Body' and 'DSL'.+--+--   See also '|-'.+data Head ctx unused+  = Head Name (NonEmpty SimpleTerm)++-- | Data type representing the body of a relation+--   (what follows after ":-" in a Datalog relation).+--+--   By being a monad, it supports do-notation which allows for a syntax+--   that is quite close to Datalog.+--+--   - The "ctx" type variable is the context in which this type is used.+--     For this type, this will always be 'Relation'. The variable is there to+--     perform some compile-time checks.+--   - The "a" type variable is the value contained inside+--     (just like other monads).+--+--   See also '|-'.+newtype Body ctx a = Body (Writer [AST] a)+  deriving (Functor, Applicative, Monad, MonadWriter [AST])+  via (Writer [AST])++-- | Creates a fragment that is the logical disjunction (OR) of 2 sub-fragments.+--   This corresponds with ";" in Datalog.+(\/) :: Body ctx () -> Body ctx () -> Body ctx ()+body1 \/ body2 = do+  let rules1 = And' $ runBody body1+      rules2 = And' $ runBody body2+  tell [Or' [rules1, rules2]]++-- | Creates a fragment that is the logical negation of a sub-fragment.+--   This is equivalent to "!" in Datalog. (But this operator can't be used+--   in Haskell since it only allows unary negation as a prefix operator.)+not' :: Body ctx a -> Body ctx ()+not' body = do+  let rules = And' $ runBody body+  tell [Not' rules]++runBody :: Body ctx a -> [AST]+runBody (Body m) = execWriter m++data TypeInfo (a :: k) (ts :: [Type]) = TypeInfo++-- | Constraint that makes sure a type can be converted to a predicate function.+--   It gives a user-friendly error in case any of the sub-constraints+--   are not met.+type ToPredicate prog a =+  ( Fact a+  , FactMetadata a+  , ContainsFact prog a+  , SimpleProduct a+  , Assert (Length (Structure a) <=? 10) BigTupleError+  , KnownDLTypes (Structure a)+  , KnownDirection (FactDirection a)+  , KnownSymbols (AccessorNames a)+  , ToTerms (Structure a)+  )++-- | A typeclass for optionally configuring extra settings+--   (for performance reasons).++--   Since it contains no required functions, it is possible to derive this+--   typeclass automatically (this gives you the default behavior):+--+--   @+--   data Edge = Edge String String+--     deriving (Generic, Marshal, FactMetadata)+--   @+class (Fact a, SimpleProduct a) => FactMetadata a where+  -- | An optional function for configuring fact metadata.+  --+  --   By default no extra options are configured.+  --   For more information, see the 'Metadata' type.+  factOpts :: Proxy a -> Metadata a+  factOpts = const $ Metadata Automatic NoInline++-- | A data type that allows for finetuning of fact settings+--   (for performance reasons).+data Metadata a+  = Metadata (StructureOpt a) (InlineOpt (FactDirection a))++-- | Datatype describing the way a fact is stored inside Datalog.+--   A different choice of storage type can lead to an improvement in+--   performance (potentially).+--+--   For more information, see this+--   <https://souffle-lang.github.io/tuning#datastructure link> and this+--   <https://souffle-lang.github.io/relations link>.+data StructureOpt (a :: Type) where+  -- | Automatically choose the underlying storage for a relation.+  --   This is the storage type that is used by default.+  --+  --   For Souffle, it will choose a direct btree for facts with arity <= 6.+  --   For larger facts, it will use an indirect btree.+  Automatic :: StructureOpt a+  -- | Uses a direct btree structure.+  BTree :: StructureOpt a+  -- | Uses a brie structure. This can improve performance in some cases and is+  --   more memory efficient for particularly large relations.+  Brie :: StructureOpt a+  -- | A high performance datastructure optimised specifically for equivalence+  --   relations. This is only valid for binary facts with 2 fields of the+  --   same type.+  EqRel :: (IsBinaryRelation a, Structure a ~ '[t, t]) => StructureOpt a++type IsBinaryRelation a =+  Assert (Length (Structure a) == 2)+         ("Equivalence relations are only allowed with binary relations" <> ".")++-- | Datatype indicating if we should inline a fact or not.+data InlineOpt (d :: Direction) where+  -- | Inlines the fact, only possible for internal facts.+  Inline :: InlineOpt 'Internal+  -- | Does not inline the fact.+  NoInline :: InlineOpt d++-- | Generates a function for a type that implements 'Fact' and is a+--   'SimpleProduct'. The predicate function takes the same amount of arguments+--   as the original fact type. Calling the function with a tuple of arguments,+--   creates fragments of datalog code that can be glued together using other+--   functions in this module.+--+--   Note: You need to specify for which fact you want to return a predicate+--   for using TypeApplications.+predicateFor :: forall a prog. ToPredicate prog a => DSL prog 'Definition (Predicate a)+predicateFor = do+  let typeInfo = TypeInfo :: TypeInfo a (Structure a)+      p = Proxy :: Proxy a+      name = T.pack $ factName p+      accNames = fromMaybe genericNames $ accessorNames p+      opts = toSimpleMetadata $ factOpts p+      genericNames = map (("t" <>) . T.pack . show) [1..]+      tys = getTypes (Proxy :: Proxy (Structure a))+      direction = getDirection (Proxy :: Proxy (FactDirection a))+      fields = zipWith FieldData tys accNames+      definition = Declare' name direction fields opts+  addDefinition definition+  pure $ Predicate $ toFragment typeInfo name++toSimpleMetadata :: Metadata a -> SimpleMetadata+toSimpleMetadata (Metadata struct inline) =+  let structOpt = case struct of+        Automatic -> AutomaticLayout+        BTree -> BTreeLayout+        Brie -> BrieLayout+        EqRel -> EqRelLayout+      inlineOpt = case inline of+        Inline -> DoInline+        NoInline -> DoNotInline+  in SimpleMetadata structOpt inlineOpt++class KnownDirection a where+  getDirection :: Proxy a -> Direction+instance KnownDirection 'Input where getDirection = const Input+instance KnownDirection 'Output where getDirection = const Output+instance KnownDirection 'InputOutput where getDirection = const InputOutput+instance KnownDirection 'Internal where getDirection = const Internal++-- | Turnstile operator from Datalog, used in relations.+--+--   This is used for creating a DSL fragment that contains a relation.+--   NOTE: |- is used instead of :- due to limitations of the Haskell syntax.+(|-) :: Head 'Relation a -> Body 'Relation () -> DSL prog 'Definition ()+Head name terms |- body =+  let rules = runBody body+      relation = Rule' name terms (And' rules)+  in addDefinition relation++infixl 0 |-++-- | A typeclass used for generating AST fragments of Datalog code.+--   The generated fragments can be further glued together using the+--   various functions in this module.+class Fragment f ctx where+  toFragment :: ToTerms ts => TypeInfo a ts -> Name -> Tuple ctx ts -> f ctx ()++instance Fragment Head 'Relation where+  toFragment typeInfo name terms =+    let terms' = toTerms (Proxy :: Proxy 'Relation) typeInfo terms+     in Head name terms'++instance Fragment Body 'Relation where+  toFragment typeInfo name terms =+    let terms' = toTerms (Proxy :: Proxy 'Relation) typeInfo terms+    in tell [Atom' name terms']++instance Fragment (DSL prog) 'Definition where+  toFragment typeInfo name terms =+    let terms' = toTerms (Proxy :: Proxy 'Definition) typeInfo terms+     in addDefinition $ Atom' name terms'+++data RenderMode = Nested | TopLevel++-- | Renders a DSL fragment to the corresponding Datalog code and writes it to+--   a file.+renderIO :: Program prog => prog -> FilePath -> DSL prog 'Definition () -> IO ()+renderIO prog path = TIO.writeFile path . render prog++-- | Renders a DSL fragment to the corresponding Datalog code.+render :: Program prog => prog -> DSL prog 'Definition () -> T.Text+render prog = flip runReader TopLevel . f . runDSL prog where+  f = \case+    Statements stmts ->+      T.unlines <$> traverse f stmts+    Declare name dir fields metadata ->+      let fieldPairs = map renderField fields+          renderedFactOpts = renderMetadata metadata+          renderedOpts = if T.null renderedFactOpts then "" else " " <> renderedFactOpts+       in pure $ T.intercalate "\n" $ catMaybes+        [ Just $ ".decl " <> name <> "(" <> T.intercalate ", " fieldPairs <> ")" <> renderedOpts+        , renderDir name dir+        ]+    Atom name terms -> do+      let rendered = name <> "(" <> renderTerms (toList terms) <> ")"+      end <- maybeDot+      pure $ rendered <> end+    Rule name terms body -> do+      body' <- f body+      let rendered =+            name <> "(" <> renderTerms (toList terms) <> ") :-\n" <>+            T.intercalate "\n" (map indent $ T.lines body')+      pure rendered+    And e1 e2 -> do+      txt <- nested $ do+        txt1 <- f e1+        txt2 <- f e2+        pure $ txt1 <> ",\n" <> txt2+      end <- maybeDot+      pure $ txt <> end+    Or e1 e2 -> do+      txt <- nested $ do+        txt1 <- f e1+        txt2 <- f e2+        pure $ txt1 <> ";\n" <> txt2+      end <- maybeDot+      case end of+        "." -> pure $ txt <> end+        _ -> pure $ "(" <> txt <> ")"+    Not e -> do+      let maybeAddParens txt = case e of+            And _ _ -> "(" <> txt <> ")"+            _ -> txt+      txt <- maybeAddParens <$> nested (f e)+      end <- maybeDot+      case end of+        "." -> pure $ "!" <> txt <> end+        _ -> pure $ "!" <> txt+    Constrain t -> do+      let t' = renderTerm t+      end <- maybeDot+      case end of+        "." -> pure $ t' <> "."+        _ -> pure t'+  indent = ("  " <>)+  nested = local (const Nested)+  maybeDot = ask >>= \case+    TopLevel -> pure "."+    Nested -> pure mempty++renderDir :: VarName -> Direction -> Maybe T.Text+renderDir name = \case+  Input -> Just $ ".input " <> name+  Output -> Just $ ".output " <> name+  InputOutput -> Just $ T.intercalate "\n"+                      $ catMaybes [renderDir name Input, renderDir name Output]+  Internal -> Nothing++renderField :: FieldData -> T.Text+renderField (FieldData ty accName) =+  let txt = case ty of+        DLNumber -> ": number"+        DLUnsigned -> ": unsigned"+        DLFloat -> ": float"+        DLString -> ": symbol"+   in accName <> txt++renderMetadata :: SimpleMetadata -> T.Text+renderMetadata (SimpleMetadata struct inline) =+  let structTxt = case struct of+        AutomaticLayout -> Nothing+        BTreeLayout -> Just "btree"+        BrieLayout -> Just "brie"+        EqRelLayout -> Just "eqrel"+      inlineTxt = case inline of+        DoInline -> Just "inline"+        DoNotInline -> Nothing+  in T.intercalate " " $ catMaybes [structTxt, inlineTxt]++renderTerms :: [SimpleTerm] -> T.Text+renderTerms = T.intercalate ", " . map renderTerm++renderTerm :: SimpleTerm -> T.Text+renderTerm = \case+  I x -> T.pack $ show x+  U x -> T.pack $ show x+  F x -> T.pack $ printf "%f" x+  S s -> "\"" <> T.pack s <> "\""+  V v -> v+  Underscore -> "_"++  BinOp' op t1 t2 -> renderTerm t1 <> " " <> renderBinOp op <> " " <> renderTerm t2+  UnaryOp' op t1 -> renderUnaryOp op <> renderTerm t1+  Func' name ts -> renderFunc name <> "(" <> renderTerms (toList ts) <> ")"+  where+    renderFunc = \case+      Max -> "max"+      Min -> "min"+      Cat -> "cat"+      Contains -> "contains"+      Match -> "match"+      Ord -> "ord"+      StrLen -> "strlen"+      Substr -> "substr"+      ToNumber -> "to_number"+      ToString -> "to_string"+    renderBinOp = \case+      Plus -> "+"+      Mul -> "*"+      Subtract -> "-"+      Div -> "/"+      Pow -> "^"+      Rem -> "%"+      BinaryAnd -> "band"+      BinaryOr -> "bor"+      BinaryXor -> "bxor"+      LogicalAnd -> "land"+      LogicalOr -> "lor"+      LessThan -> "<"+      LessThanOrEqual -> "<="+      GreaterThan -> ">"+      GreaterThanOrEqual -> ">="+      IsEqual -> "="+      IsNotEqual -> "!="+    renderUnaryOp Negate = "-"+++type Name = T.Text++-- | Type representing a variable name in Datalog.+type VarName = T.Text++type AccessorName = T.Text++data DLType+  = DLNumber+  | DLUnsigned+  | DLFloat+  | DLString++data FieldData = FieldData DLType AccessorName++-- | A type level tag describing in which context a DSL fragment is used.+--   This is only used on the type level and helps catch some semantic errors+--   at compile time.+data UsageContext+  = Definition+  -- ^ A DSL fragment is used in a top level definition.+  | Relation+  -- ^ A DSL fragment is used inside a relation (either head or body of a relation).++-- | A type family used for generating a user-friendly type error in case+--   you use a variable in a DSL fragment where it is not allowed+--   (outside of relations).+type family NoVarsInAtom (ctx :: UsageContext) :: Constraint where+  NoVarsInAtom ctx = Assert (ctx == 'Relation) NoVarsInAtomError++type NoVarsInAtomError =+  ( "You tried to use a variable in a top level fact, which is not supported in Souffle."+  % "Possible solutions:"+  % "  - Move the fact inside a rule body."+  % "  - Replace the variable in the fact with a string, number, unsigned or float constant."+  )++-- | Data type for representing Datalog terms.+--+--   All constructors are hidden, but with the `Num`, 'Fractional' and+--   `IsString` instances it is possible to create terms using Haskell syntax+--   for literals. For non-literal values, smart constructors are provided.+--   (See for example 'underscore' / '__'.)+data Term ctx ty where+  -- NOTE: type family is used here instead of "Term 'Relation ty";+  -- this allows giving a better type error in some situations.+  VarTerm :: NoVarsInAtom ctx => VarName -> Term ctx ty+  UnderscoreTerm :: Term ctx ty+  NumberTerm :: Int32 -> Term ctx Int32+  UnsignedTerm :: Word32 -> Term ctx Word32+  FloatTerm :: Float -> Term ctx Float+  StringTerm :: ToString ty => ty -> Term ctx ty++  UnaryOp :: Num ty => Op1 -> Term ctx ty -> Term ctx ty+  BinOp :: Num ty => Op2 -> Term ctx ty -> Term ctx ty -> Term ctx ty+  Func :: FuncName -> NonEmpty SimpleTerm -> Term ctx ty2++data Op2+  = Plus+  | Mul+  | Subtract+  | Div+  | Pow+  | Rem+  | BinaryAnd+  | BinaryOr+  | BinaryXor+  | LogicalAnd+  | LogicalOr+  | LessThan+  | LessThanOrEqual+  | GreaterThan+  | GreaterThanOrEqual+  | IsEqual+  | IsNotEqual++data Op1 = Negate++data FuncName+  = Max+  | Min+  | Cat+  | Contains+  | Match+  | Ord+  | StrLen+  | Substr+  | ToNumber+  | ToString+++-- | Term representing a wildcard ("_") in Datalog.+underscore :: Term ctx ty+underscore = UnderscoreTerm++-- | Term representing a wildcard ("_") in Datalog. Note that in the DSL this+--   is with 2 underscores. (Single underscore is reserved for typed holes!)+__ :: Term ctx ty+__ = underscore++class ToString a where+  toString :: a -> String++instance ToString String where toString = id+instance ToString T.Text where toString = T.unpack+instance ToString TL.Text where toString = TL.unpack++instance IsString (Term ctx String) where fromString = StringTerm+instance IsString (Term ctx T.Text) where fromString = StringTerm . T.pack+instance IsString (Term ctx TL.Text) where fromString = StringTerm . TL.pack++-- | A helper typeclass, mainly used for avoiding a lot of boilerplate+--   in the 'Num' instance for 'Term'.+class Num ty => SupportsArithmetic ty where+  fromInteger' :: Integer -> Term ctx ty++instance SupportsArithmetic Int32 where+  fromInteger' = NumberTerm . fromInteger+instance SupportsArithmetic Word32 where+  fromInteger' = UnsignedTerm . fromInteger+instance SupportsArithmetic Float where+  fromInteger' = FloatTerm . fromInteger++instance (SupportsArithmetic ty, Num ty) => Num (Term ctx ty) where+  fromInteger = fromInteger'+  (+) = BinOp Plus+  (*) = BinOp Mul+  (-) = BinOp Subtract+  negate = UnaryOp Negate+  abs = error "'abs' is not supported for Souffle terms"+  signum = error "'signum' is not supported for Souffle terms"++instance Fractional (Term ctx Float) where+  fromRational = FloatTerm . fromRational+  (/) = BinOp Div++-- | Exponentiation operator ("^" in Datalog).+(.^) :: Num ty => Term ctx ty -> Term ctx ty -> Term ctx ty+(.^) = BinOp Pow++-- | Remainder operator ("%" in Datalog).+(.%) :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+(.%) = BinOp Rem++-- | Creates a less than constraint (a < b), for use in the body of a relation.+(.<) :: Num ty => Term ctx ty -> Term ctx ty -> Body ctx ()+(.<) = addConstraint LessThan+infix 1 .<++-- | Creates a less than or equal constraint (a <= b), for use in the body of+--   a relation.+(.<=) :: Num ty => Term ctx ty -> Term ctx ty -> Body ctx ()+(.<=) = addConstraint LessThanOrEqual+infix 1 .<=++-- | Creates a greater than constraint (a > b), for use in the body of a relation.+(.>) :: Num ty => Term ctx ty -> Term ctx ty -> Body ctx ()+(.>) = addConstraint GreaterThan+infix 1 .>++-- | Creates a greater than or equal constraint (a >= b), for use in the body of+--   a relation.+(.>=) :: Num ty => Term ctx ty -> Term ctx ty -> Body ctx ()+(.>=) = addConstraint GreaterThanOrEqual+infix 1 .>=++-- | Creates a constraint that 2 terms should be equal to each other (a = b),+--   for use in the body of a relation.+(.=) :: Term ctx ty -> Term ctx ty -> Body ctx ()+(.=) = addConstraint IsEqual+infix 1 .=++-- | Creates a constraint that 2 terms should not be equal to each other+--   (a != b), for use in the body of a relation.+(.!=) :: Term ctx ty -> Term ctx ty -> Body ctx ()+(.!=) = addConstraint IsNotEqual+infix 1 .!=++addConstraint :: Op2 -> Term ctx ty -> Term ctx ty -> Body ctx ()+addConstraint op e1 e2 =+  let expr = BinOp' op (toTerm e1) (toTerm e2)+   in tell [Constrain' expr]++-- | Binary AND operator.+band :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+band = BinOp BinaryAnd++-- | Binary OR operator.+bor :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+bor = BinOp BinaryOr++-- | Binary XOR operator.+bxor :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+bxor = BinOp BinaryXor++-- | Logical AND operator.+land :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+land = BinOp LogicalAnd++-- | Logical OR operator.+lor :: (Num ty, Integral ty) => Term ctx ty -> Term ctx ty -> Term ctx ty+lor = BinOp LogicalOr++-- | "max" function.+max' :: Num ty => Term ctx ty -> Term ctx ty -> Term ctx ty+max' = func2 Max++-- | "min" function.+min' :: Num ty => Term ctx ty -> Term ctx ty -> Term ctx ty+min' = func2 Min++-- | "cat" function (string concatenation).+cat :: ToString ty => Term ctx ty -> Term ctx ty -> Term ctx ty+cat = func2 Cat++-- | "contains" predicate, checks if 2nd string contains the first.+contains :: ToString ty => Term ctx ty -> Term ctx ty -> Body ctx ()+contains a b =+  let expr = toTerm $ func2 Contains a b+   in tell [Constrain' expr]++-- | "match" predicate, checks if a wildcard string matches a given string.+match :: ToString ty => Term ctx ty -> Term ctx ty -> Body ctx ()+match p s =+  let expr = toTerm $ func2 Match p s+  in tell [Constrain' expr]++-- | "ord" function.+ord :: ToString ty => Term ctx ty -> Term ctx Int32+ord = func1 Ord++-- | "strlen" function.+strlen :: ToString ty => Term ctx ty -> Term ctx Int32+strlen = func1 StrLen++-- | "substr" function.+substr :: ToString ty => Term ctx ty -> Term ctx Int32 -> Term ctx Int32 -> Term ctx ty+substr a b c = Func Substr $ toTerm a :| [toTerm b, toTerm c]++-- | "to_number" function.+to_number :: ToString ty => Term ctx ty -> Term ctx Int32+to_number = func1 ToNumber++-- | "to_string" function.+to_string :: ToString ty => Term ctx Int32 -> Term ctx ty+to_string = func1 ToString++func1 :: FuncName -> Term ctx ty -> Term ctx ty2+func1 name a = Func name $ toTerm a :| []++func2 :: FuncName -> Term ctx ty -> Term ctx ty -> Term ctx ty2+func2 name a b = Func name $ toTerm a :| [toTerm b]++data SimpleTerm+  = V VarName+  | I Int32+  | U Word32+  | F Float+  | S String+  | Underscore++  | BinOp' Op2 SimpleTerm SimpleTerm+  | UnaryOp' Op1 SimpleTerm+  | Func' FuncName (NonEmpty SimpleTerm)++data SimpleMetadata = SimpleMetadata StructureOption InlineOption++data StructureOption+  = AutomaticLayout+  | BTreeLayout+  | BrieLayout+  | EqRelLayout++data InlineOption+  = DoInline+  | DoNotInline++data AST+  = Declare' VarName Direction [FieldData] SimpleMetadata+  | Rule' Name (NonEmpty SimpleTerm) AST+  | Atom' Name (NonEmpty SimpleTerm)+  | And' [AST]+  | Or' [AST]+  | Not' AST+  | Constrain' SimpleTerm++data DL+  = Statements [DL]+  | Declare VarName Direction [FieldData] SimpleMetadata+  | Rule Name (NonEmpty SimpleTerm) DL+  | Atom Name (NonEmpty SimpleTerm)+  | And DL DL+  | Or DL DL+  | Not DL+  | Constrain SimpleTerm+++class KnownDLTypes (ts :: [Type]) where+  getTypes :: Proxy ts -> [DLType]++instance KnownDLTypes '[] where+  getTypes _ = []++instance (KnownDLType t, KnownDLTypes ts) => KnownDLTypes (t ': ts) where+  getTypes _ = getType (Proxy :: Proxy t) : getTypes (Proxy :: Proxy ts)++class KnownDLType t where+  getType :: Proxy t -> DLType++instance KnownDLType Int32 where getType = const DLNumber+instance KnownDLType Word32 where getType = const DLUnsigned+instance KnownDLType Float where getType = const DLFloat+instance KnownDLType String where getType = const DLString+instance KnownDLType T.Text where getType = const DLString+instance KnownDLType TL.Text where getType = const DLString++type family AccessorNames a :: [Symbol] where+  AccessorNames a = GetAccessorNames (Rep a)++type family GetAccessorNames (f :: Type -> Type) :: [Symbol] where+  GetAccessorNames (a :*: b) = GetAccessorNames a ++ GetAccessorNames b+  GetAccessorNames (C1 ('MetaCons _ _ 'False) _) = '[]+  GetAccessorNames (S1 ('MetaSel ('Just name) _ _ _) a) = '[name] ++ GetAccessorNames a+  GetAccessorNames (M1 _ _ a) = GetAccessorNames a+  GetAccessorNames (K1 _ _) = '[]++class KnownSymbols (symbols :: [Symbol]) where+  toStrings :: Proxy symbols -> [String]++instance KnownSymbols '[] where+  toStrings = const []++instance (KnownSymbol s, KnownSymbols symbols) => KnownSymbols (s ': symbols) where+  toStrings _ =+    let sym = symbolVal (Proxy :: Proxy s)+        symbols =  toStrings (Proxy :: Proxy symbols)+     in sym : symbols++accessorNames :: forall a. KnownSymbols (AccessorNames a) => Proxy a -> Maybe [T.Text]+accessorNames _ = case toStrings (Proxy :: Proxy (AccessorNames a)) of+  [] -> Nothing+  names -> Just $ T.pack <$> names++-- | A type synonym for a tuple consisting of Datalog 'Term's.+--   Only tuples containing up to 10 elements are currently supported.+type Tuple ctx ts = TupleOf (MapType (Term ctx) ts)++class ToTerms (ts :: [Type]) where+  toTerms :: Proxy ctx -> TypeInfo a ts -> Tuple ctx ts -> NonEmpty SimpleTerm++instance ToTerms '[t] where+  toTerms _ _ a =+    toTerm a :| []++instance ToTerms '[t1, t2] where+  toTerms _ _ (a, b) =+    toTerm a :| [toTerm b]++instance ToTerms '[t1, t2, t3] where+  toTerms _ _ (a, b, c) =+    toTerm a :| [toTerm b, toTerm c]++instance ToTerms '[t1, t2, t3, t4] where+  toTerms _ _ (a, b, c, d) =+    toTerm a :| [toTerm b, toTerm c, toTerm d]++instance ToTerms '[t1, t2, t3, t4, t5] where+  toTerms _ _ (a, b, c, d, e) =+    toTerm a :| [toTerm b, toTerm c, toTerm d, toTerm e]++instance ToTerms '[t1, t2, t3, t4, t5, t6] where+  toTerms _ _ (a, b, c, d, e, f) =+    toTerm a :| [toTerm b, toTerm c, toTerm d, toTerm e, toTerm f]++instance ToTerms '[t1, t2, t3, t4, t5, t6, t7] where+  toTerms _ _ (a, b, c, d, e, f, g) =+    toTerm a :| [toTerm b, toTerm c, toTerm d, toTerm e, toTerm f, toTerm g]++instance ToTerms '[t1, t2, t3, t4, t5, t6, t7, t8] where+  toTerms _ _ (a, b, c, d, e, f, g, h) =+    toTerm a :| [toTerm b, toTerm c, toTerm d, toTerm e, toTerm f, toTerm g, toTerm h]++instance ToTerms '[t1, t2, t3, t4, t5, t6, t7, t8, t9] where+  toTerms _ _ (a, b, c, d, e, f, g, h, i) =+    toTerm a :| [toTerm b, toTerm c, toTerm d, toTerm e, toTerm f, toTerm g, toTerm h, toTerm i]++instance ToTerms '[t1, t2, t3, t4, t5, t6, t7, t8, t9, t10] where+  toTerms _ _ (a, b, c, d, e, f, g, h, i, j) =+    toTerm a :| [ toTerm b, toTerm c, toTerm d, toTerm e, toTerm f+                , toTerm g, toTerm h, toTerm i, toTerm j+                ]++toTerm :: Term ctx t -> SimpleTerm+toTerm = \case+  VarTerm v -> V v+  StringTerm s -> S $ toString s+  NumberTerm x -> I x+  UnsignedTerm x -> U x+  FloatTerm x -> F x+  UnderscoreTerm -> Underscore++  BinOp op t1 t2 -> BinOp' op (toTerm t1) (toTerm t2)+  UnaryOp op t1 -> UnaryOp' op (toTerm t1)+  Func name ts -> Func' name ts+++-- Helper functions / type families / ...++type family MapType (f :: Type -> Type) (ts :: [Type]) :: [Type] where+  MapType _ '[] = '[]+  MapType f (t ': ts) = f t ': MapType f ts++type family Assert (c :: Bool) (msg :: ErrorMessage) :: Constraint where+  Assert 'True _ = ()+  Assert 'False msg = TypeError msg++type family (a :: k) == (b :: k) :: Bool where+  a == a = 'True+  _ == _ = 'False++type family Length (xs :: [Type]) :: Nat where+  Length '[] = 0+  Length (_ ': xs) = 1 + Length xs++-- | A helper type family for computing the list of types used in a data type.+--   (The type family assumes a data type with a single data constructor.)+type family Structure a :: [Type] where+  Structure a = Collect (Rep a)++type family Collect (a :: Type -> Type) where+  Collect (a :*: b) = Collect a ++ Collect b+  Collect (M1 _ _ a) = Collect a+  Collect (K1 _ ty) = '[ty]++type family a ++ b = c where+  '[] ++ b = b+  a ++ '[] = a+  (a ': b) ++ c = a ': (b ++ c)++type family TupleOf (ts :: [Type]) = t where+  TupleOf '[t] = t+  TupleOf '[t1, t2] = (t1, t2)+  TupleOf '[t1, t2, t3] = (t1, t2, t3)+  TupleOf '[t1, t2, t3, t4] = (t1, t2, t3, t4)+  TupleOf '[t1, t2, t3, t4, t5] = (t1, t2, t3, t4, t5)+  TupleOf '[t1, t2, t3, t4, t5, t6] = (t1, t2, t3, t4, t5, t6)+  TupleOf '[t1, t2, t3, t4, t5, t6, t7] = (t1, t2, t3, t4, t5, t6, t7)+  TupleOf '[t1, t2, t3, t4, t5, t6, t7, t8] = (t1, t2, t3, t4, t5, t6, t7, t8)+  TupleOf '[t1, t2, t3, t4, t5, t6, t7, t8, t9] = (t1, t2, t3, t4, t5, t6, t7, t8, t9)+  TupleOf '[t1, t2, t3, t4, t5, t6, t7, t8, t9, t10] = (t1, t2, t3, t4, t5, t6, t7, t8, t9, t10)+  TupleOf _ = TypeError BigTupleError++type BigTupleError =+  ( "The DSL only supports facts/tuples consisting of up to 10 elements."+  % "If you need more arguments, please submit an issue on Github "+  <> "(https://github.com/luc-tielen/souffle-haskell/issues)"+  )+

@@ -21,13 +21,11 @@ --   the 'Language.Souffle.Marshal.Marshal' typeclass. -- --   The __a__ type parameter is the original type, used when displaying the type error.---   The __f__ type parameter should be equal to 'Rep a', used for analyzing the---   structure of the data type. -- --   A type error is returned if the passed in type is not a simple product type---   consisting of only simple types like Int32, String and Text.-type family SimpleProduct (a :: Type) (f :: Type -> Type) :: Constraint where-  SimpleProduct a f = (ProductLike a f, OnlySimpleFields a f)+--   consisting of only "simple" types like Int32, Word32, Float, String and Text.+type family SimpleProduct (a :: Type) :: Constraint where+  SimpleProduct a = (ProductLike a (Rep a), OnlySimpleFields a (Rep a))  type family ProductLike (t :: Type) (f :: Type -> Type) :: Constraint where   ProductLike t (_ :*: b) = ProductLike t b

@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-}-{-# LANGUAGE FlexibleInstances, TypeFamilies, DerivingVia, InstanceSigs #-}+{-# LANGUAGE FlexibleInstances, TypeFamilies, DerivingVia, InstanceSigs, UndecidableInstances #-}  -- | This module provides an implementation for the `MonadSouffle` typeclass --   defined in "Language.Souffle.Class".@@ -13,6 +13,9 @@   ( Program(..)   , Fact(..)   , Marshal(..)+  , Direction(..)+  , ContainsInputFact+  , ContainsOutputFact   , Config(..)   , Handle   , SouffleM@@ -20,7 +23,6 @@   , runSouffle   , runSouffleWith   , defaultConfig-  , cleanup   , souffleStdOut   , souffleStdErr   ) where@@ -69,7 +71,7 @@ --   - __cfgFactDir__: The directory where the initial input fact file(s) can be found --   if present. If Nothing, then a temporary directory will be used, during the --   souffle session.---   - __cfgOutputDir__: The directory where the output facts file(s) are created.+--   - __cfgOutputDir__: The directory where the output fact file(s) are created. --   If Nothing, it will be part of the temporary directory. data Config   = Config@@ -100,18 +102,65 @@   pure $ Config (fromMaybe "." dlDir) souffleBin Nothing Nothing {-# INLINABLE defaultConfig #-} --- | Returns an IO action that will run the Souffle interpreter with---   default settings (see `defaultConfig`).-runSouffle :: SouffleM a -> IO a-runSouffle m = do+{- | Initializes and runs a Souffle program with default settings.++     The 2nd argument is passed in a handle after initialization of the+     Souffle program. The handle will contain 'Nothing' if it failed to+     locate the souffle interpreter executable or if it failed to find the+     souffle program file. In the successful case it will contain a handle+     that can be used for performing Souffle related actions using the other+     functions in this module.+-}+runSouffle :: Program prog => prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a+runSouffle program m = do   cfg <- defaultConfig-  runSouffleWith cfg m+  runSouffleWith cfg program m {-# INLINABLE runSouffle #-} --- | Returns an IO action that will run the Souffle interpreter with---   the given interpreter settings.-runSouffleWith :: Config -> SouffleM a -> IO a-runSouffleWith cfg (SouffleM m) = runReaderT m cfg+{- | Initializes and runs a Souffle program with the given interpreter settings.++     The 3rd argument is passed in a handle after initialization of the+     Souffle program. The handle will contain 'Nothing' if it failed to+     locate the souffle interpreter executable or if it failed to find the+     souffle program file. In the successful case it will contain a handle+     that can be used for performing Souffle related actions using the other+     functions in this module.++     If the config settings do not specify a fact or output dir,+     temporary directories will be created for storing files in. These+     directories will also be automatically cleaned up at the end of+     this function.+-}+runSouffleWith+  :: Program prog => Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a+runSouffleWith cfg program f = bracket initialize maybeCleanup $ \handle -> do+  let (SouffleM action) = f handle+  runReaderT action cfg+  where+    initialize = datalogProgramFile program (cfgDatalogDir cfg) >>= \case+      Nothing -> pure Nothing+      Just datalogExecutable -> do+        tmpDir <- getCanonicalTemporaryDirectory+        souffleTempDir <- createTempDirectory tmpDir "souffle-haskell"+        let factDir = fromMaybe (souffleTempDir </> "fact") $ cfgFactDir cfg+            outDir = fromMaybe (souffleTempDir </> "out") $ cfgOutputDir cfg+        traverse_ (createDirectoryIfMissing True) [factDir, outDir]+        forM mSouffleBin $ \souffleBin ->+          Handle+            <$> (newIORef $ HandleData+                  { soufflePath = souffleBin+                  , tmpDirPath  = souffleTempDir+                  , factPath    = factDir+                  , outputPath  = outDir+                  , datalogExec = datalogExecutable+                  , noOfThreads = 1+                  })+            <*> newIORef Nothing+            <*> newIORef Nothing+    maybeCleanup = maybe mempty $ \h -> do+      handle <- readIORef $ handleData h+      removeDirectoryRecursive $ tmpDirPath handle+    mSouffleBin = cfgSouffleBin cfg {-# INLINABLE runSouffleWith #-}  -- | A datatype representing a handle to a datalog program.@@ -128,7 +177,7 @@ --   is stored. data HandleData = HandleData   { soufflePath :: FilePath-  , basePath    :: FilePath+  , tmpDirPath  :: FilePath   , factPath    :: FilePath   , outputPath  :: FilePath   , datalogExec :: FilePath@@ -206,34 +255,6 @@   type Handler SouffleM = Handle   type CollectFacts SouffleM c = Collect c -  init :: forall prog. Program prog => prog -> SouffleM (Maybe (Handle prog))-  init prg = SouffleM $ datalogProgramFile prg >>= \case-    Nothing -> pure Nothing-    Just datalogExecutable -> do-      souffleTempDir <- liftIO $ do-        tmpDir <- getCanonicalTemporaryDirectory-        createTempDirectory tmpDir "souffle-haskell"--      factDir <- fromMaybe (souffleTempDir </> "fact") <$> asks cfgFactDir-      outDir <- fromMaybe (souffleTempDir </> "out") <$> asks cfgOutputDir-      liftIO $ do-        createDirectoryIfMissing True factDir-        createDirectoryIfMissing True outDir-      mSouffleBin <- asks cfgSouffleBin-      liftIO $ forM mSouffleBin $ \souffleBin ->-        Handle-          <$> (newIORef $ HandleData-                { soufflePath = souffleBin-                , basePath    = souffleTempDir-                , factPath    = factDir-                , outputPath  = outDir-                , datalogExec = datalogExecutable-                , noOfThreads = 1-                })-          <*> newIORef Nothing-          <*> newIORef Nothing-  {-# INLINABLE init #-}-   run (Handle refHandleData refHandleStdOut refHandleStdErr) = liftIO $ do     handle <- readIORef refHandleData     -- Invoke the souffle binary using parameters, supposing that the facts@@ -277,7 +298,7 @@     noOfThreads <$> readIORef (handleData handle)   {-# INLINABLE getNumThreads #-} -  getFacts :: forall a c prog. (Marshal a, Fact a, ContainsFact prog a, Collect c)+  getFacts :: forall a c prog. (Marshal a, Fact a, ContainsOutputFact prog a, Collect c)            => Handle prog -> SouffleM (c a)   getFacts h = liftIO $ do     handle <- readIORef $ handleData h@@ -287,14 +308,14 @@     pure $! facts  -- force facts before running to avoid issues with lazy IO   {-# INLINABLE getFacts #-} -  findFact :: (Fact a, ContainsFact prog a, Eq a)+  findFact :: (Fact a, ContainsOutputFact prog a, Eq a)            => Handle prog -> a -> SouffleM (Maybe a)   findFact prog fact = do     facts :: [a] <- getFacts prog     pure $ find (== fact) facts   {-# INLINABLE findFact #-} -  addFact :: forall a prog. (Fact a, ContainsFact prog a, Marshal a)+  addFact :: forall a prog. (Fact a, ContainsInputFact prog a, Marshal a)           => Handle prog -> a -> SouffleM ()   addFact h fact = liftIO $ do     handle <- readIORef $ handleData h@@ -304,7 +325,7 @@     appendFile factFile $ intercalate "\t" line ++ "\n"   {-# INLINABLE addFact #-} -  addFacts :: forall a prog f. (Fact a, ContainsFact prog a, Marshal a, Foldable f)+  addFacts :: forall a prog f. (Fact a, ContainsInputFact prog a, Marshal a, Foldable f)            => Handle prog -> f a -> SouffleM ()   addFacts h facts = liftIO $ do     handle <- readIORef $ handleData h@@ -314,11 +335,10 @@     traverse_ (\line -> appendFile factFile (intercalate "\t" line ++ "\n")) factLines   {-# INLINABLE addFacts #-} -datalogProgramFile :: forall prog. Program prog => prog -> ReaderT Config IO (Maybe FilePath)-datalogProgramFile _ = do-  dir <- asks cfgDatalogDir-  let dlFile = dir </> programName (Proxy :: Proxy prog) <.> "dl"-  liftIO $ doesFileExist dlFile >>= \case+datalogProgramFile :: forall prog. Program prog => prog -> FilePath -> IO (Maybe FilePath)+datalogProgramFile prog datalogDir = do+  let dlFile = datalogDir </> programName prog <.> "dl"+  doesFileExist dlFile >>= \case     False -> pure Nothing     True -> pure $ Just dlFile {-# INLINABLE datalogProgramFile #-}@@ -343,15 +363,6 @@     -- deepseq needed to avoid issues with lazy IO     pure $ contents `deepseq` (map (splitOn '\t') . lines) contents {-# INLINABLE readCSVFile #-}---- | Cleans up the temporary directory that this library has written files to.---   This functionality is only provided for the interpreted version since the---   compiled version directly (de-)serializes data via the C++ API.-cleanup :: forall prog. Program prog => Handle prog -> SouffleM ()-cleanup h  = liftIO $ do-  handle <- readIORef $ handleData h-  traverse_ removeDirectoryRecursive [factPath handle, outputPath handle, basePath handle]-{-# INLINABLE cleanup #-}  -- | Returns the handle of stdout from the souffle interpreter. souffleStdOut :: forall prog. Program prog => Handle prog -> SouffleM (Maybe T.Text)

@@ -77,10 +77,10 @@   pop :: MonadPop m => m a    default push-    :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadPush m)+    :: (Generic a, C.SimpleProduct a, GMarshal (Rep a), MonadPush m)     => a -> m ()   default pop-    :: (Generic a, C.SimpleProduct a (Rep a), GMarshal (Rep a), MonadPop m)+    :: (Generic a, C.SimpleProduct a, GMarshal (Rep a), MonadPop m)     => m a   push a = gpush (from a)   {-# INLINABLE push #-}

@@ -1,4 +1,4 @@-{-# LANGUAGE DataKinds, TypeFamilies, DeriveGeneric, DeriveAnyClass #-}+{-# LANGUAGE DataKinds, TypeFamilies, DeriveGeneric, DeriveAnyClass, TypeApplications #-}  module Main ( main ) where @@ -20,33 +20,72 @@ import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as P import qualified Language.Souffle.Interpreted as Souffle+import Language.Souffle.Experimental   data Includes = Includes FilePath FilePath-  deriving (Eq, Show, Generic, Souffle.Marshal)+  deriving (Eq, Show, Generic, Souffle.Marshal, FactMetadata) +data TransitivelyIncludes = TransitivelyIncludes FilePath FilePath+  deriving (Eq, Show, Generic, Souffle.Marshal, FactMetadata)+ newtype TopLevelInclude = TopLevelInclude FilePath-  deriving (Eq, Show, Generic, Souffle.Marshal)+  deriving (Eq, Show, Generic, Souffle.Marshal, FactMetadata)  newtype RequiredInclude = RequiredInclude FilePath-  deriving (Eq, Show, Generic, Souffle.Marshal)+  deriving (Eq, Show, Generic, Souffle.Marshal, FactMetadata)  data Handle = Handle  instance Souffle.Program Handle where-  type ProgramFacts Handle = [TopLevelInclude, Includes, RequiredInclude]+  type ProgramFacts Handle =+    [ TopLevelInclude+    , Includes+    , TransitivelyIncludes+    , RequiredInclude+    ]   programName = const "required_include"  instance Souffle.Fact Includes where+  type FactDirection Includes = 'Souffle.Input   factName = const "includes" +instance Souffle.Fact TransitivelyIncludes where+  type FactDirection TransitivelyIncludes = 'Souffle.Internal+  factName = const "transitively_includes"+ instance Souffle.Fact TopLevelInclude where+  type FactDirection TopLevelInclude = 'Souffle.Input   factName = const "top_level_include"  instance Souffle.Fact RequiredInclude where+  type FactDirection RequiredInclude = 'Souffle.Output   factName = const "required_include" +dlProgram :: DSL Handle 'Definition ()+dlProgram = do+  Predicate includes <- predicateFor @Includes+  Predicate transitivelyIncludes <- predicateFor @TransitivelyIncludes+  Predicate topLevelInclude <- predicateFor @TopLevelInclude+  Predicate requiredInclude <- predicateFor @RequiredInclude +  file1 <- var "file1"+  file2 <- var "file2"+  file3 <- var "file3"++  requiredInclude(file1) |-+    topLevelInclude(file1)+  requiredInclude(file1) |- do+    topLevelInclude(file2)+    transitivelyIncludes(file2, file1)++  transitivelyIncludes(file1, file2) |-+    includes(file1, file2)+  transitivelyIncludes(file1, file2) |- do+    includes(file1, file3)+    transitivelyIncludes(file3, file2)++ run :: String -> IO () run = callCommand @@ -114,18 +153,15 @@  computeRequiredIncludes :: [Includes] -> IO [FilePath] computeRequiredIncludes includes = do-  cfg <- Souffle.defaultConfig-  let config = cfg { Souffle.cfgDatalogDir = "./scripts" }-  requiredIncludes <- Souffle.runSouffleWith config $-    Souffle.init Handle >>= \case-      Nothing -> error "Failed to load Souffle program. Aborting."-      Just prog -> do-        Souffle.addFacts prog [ TopLevelInclude "souffle/src/SouffleInterface.h"-                              , TopLevelInclude "souffle/src/CompiledSouffle.h"-                              ]-        Souffle.addFacts prog includes-        Souffle.run prog-        Souffle.getFacts prog+  requiredIncludes <- runSouffleInterpreted Handle dlProgram $ \case+    Nothing -> error "Failed to load Souffle program. Aborting."+    Just prog -> do+      Souffle.addFacts prog [ TopLevelInclude "souffle/src/SouffleInterface.h"+                            , TopLevelInclude "souffle/src/CompiledSouffle.h"+                            ]+      Souffle.addFacts prog includes+      Souffle.run prog+      Souffle.getFacts prog   pure $ map (\(RequiredInclude include) -> include) requiredIncludes  copyHeader :: FilePath -> IO FilePath

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0e669f6fe266f6ab6d74d38303f2f74ccf8b6264c4aec9aeb972e5e76b38d236+-- hash: d1e5d51d922f3a246fbf5e312f90e05c4ad621f11985cb4fbe1de6ac504bd730  name:           souffle-haskell-version:        1.1.0+version:        2.0.0 synopsis:       Souffle Datalog bindings for Haskell description:    Souffle Datalog bindings for Haskell. category:       Logic Programming, Foreign Binding, Bindings@@ -79,6 +79,7 @@   exposed-modules:       Language.Souffle.Class       Language.Souffle.Compiled+      Language.Souffle.Experimental       Language.Souffle.Internal       Language.Souffle.Internal.Bindings       Language.Souffle.Internal.Constraints@@ -92,6 +93,7 @@       lib   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   cxx-options: -std=c++17 -Wall   include-dirs:       cbits@@ -143,6 +145,7 @@   build-depends:       array <=1.0     , base >=4.12 && <5+    , containers >=0.6.2.1 && <1     , deepseq >=1.4.4 && <2     , directory >=1.3.3 && <2     , filepath >=1.4.2 && <2@@ -166,6 +169,7 @@       scripts   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   cxx-options: -std=c++17   include-dirs:       cbits@@ -236,6 +240,9 @@   main-is: test.hs   other-modules:       Test.Language.Souffle.CompiledSpec+      Test.Language.Souffle.Experimental.Fixtures+      Test.Language.Souffle.Experimental.FixturesCompiled+      Test.Language.Souffle.ExperimentalSpec       Test.Language.Souffle.InterpretedSpec       Test.Language.Souffle.MarshalSpec       Paths_souffle_haskell@@ -243,6 +250,7 @@       tests   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__   cxx-options: -std=c++17 -D__EMBEDDED_SOUFFLE__   include-dirs:       cbits@@ -295,6 +303,7 @@   build-depends:       array <=1.0     , base >=4.12 && <5+    , containers >=0.6.2.1 && <1     , deepseq >=1.4.4 && <2     , directory >=1.3.3 && <2     , filepath >=1.4.2 && <2@@ -302,6 +311,7 @@     , hspec >=2.6.1 && <3.0.0     , hspec-hedgehog ==0.*     , mtl >=2.0 && <3+    , neat-interpolation ==0.*     , process >=1.6 && <2     , souffle-haskell     , template-haskell >=2 && <3

@@ -24,9 +24,11 @@   programName = const "path"  instance Souffle.Fact Edge where+  type FactDirection Edge = 'Souffle.InputOutput   factName = const "edge"  instance Souffle.Fact Reachable where+  type FactDirection Reachable = 'Souffle.Output   factName = const "reachable"  instance Souffle.Marshal Edge@@ -43,18 +45,18 @@ spec :: Spec spec = describe "Souffle API" $ parallel $ do   describe "init" $ parallel $ do-    it "returns nothing if it cannot load a souffle program" $ do-      prog <- Souffle.runSouffle (Souffle.init BadPath)+    it "returns nothing in case it cannot load a souffle program" $ do+      prog <- Souffle.runSouffle BadPath pure       isJust prog `shouldBe` False -    it "returns just the program if it can load a souffle program" $ do-      prog <- Souffle.runSouffle (Souffle.init Path)+    it "returns just the program in case it can load a souffle program" $ do+      prog <- Souffle.runSouffle Path pure       isJust prog `shouldBe` True    describe "getFacts" $ parallel $ do     it "can retrieve facts as a list" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (edges, reachables) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog@@ -63,8 +65,8 @@       reachables `shouldBe` [Reachable "b" "c", Reachable "a" "c", Reachable "a" "b"]      it "can retrieve facts as a vector" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (edges, reachables) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog@@ -73,8 +75,8 @@       reachables `shouldBe` V.fromList [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]      it "can retrieve facts as an array" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (edges, reachables) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog@@ -82,16 +84,16 @@       edges `shouldBe` A.listArray (0 :: Int, 1) [Edge "a" "b", Edge "b" "c"]       reachables `shouldBe` A.listArray (0 :: Int, 2) [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"] -    it "returns no facts if program hasn't run yet" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+    it "returns no facts in case program hasn't run yet" $ do+      edges <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.getFacts prog       edges `shouldBe` ([] :: [Edge]) -  describe "addFact" $ parallel $ do+  describe "addFact" $ parallel $     it "adds a fact" $ do-      (edgesBefore, edgesAfter) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (edgesBefore, edgesAfter) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es1 <- Souffle.getFacts prog         Souffle.addFact prog $ Edge "e" "f"@@ -101,20 +103,10 @@       edgesBefore `shouldBe` [Edge "b" "c", Edge "a" "b"]       edgesAfter `shouldBe` [Edge "e" "f", Edge "b" "c", Edge "a" "b"] -    -- NOTE: this is different compared to interpreted version (bug in Souffle?)-    it "can add a fact even if it is marked as output" $ do-      reachables <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path-        Souffle.addFact prog $ Reachable "e" "f"-        Souffle.run prog-        Souffle.getFacts prog-      reachables `shouldBe` [ Reachable "e" "f", Reachable "b" "c"-                            , Reachable "a" "c", Reachable "a" "b" ]-   describe "addFacts" $ parallel $     it "can add multiple facts at once" $ do-      (edgesBefore, edgesAfter) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (edgesBefore, edgesAfter) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es1 <- Souffle.getFacts prog         Souffle.addFacts prog [Edge "e" "f", Edge "f" "g"]@@ -126,16 +118,16 @@    describe "run" $ parallel $ do     it "is OK to run a program multiple times" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      edges <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         Souffle.run prog         Souffle.getFacts prog       edges `shouldBe` [Edge "b" "c", Edge "a" "b"]      it "discovers new facts after running with new facts" $ do-      (reachablesBefore, reachablesAfter) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (reachablesBefore, reachablesAfter) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         rs1 <- Souffle.getFacts prog         Souffle.addFacts prog [Edge "e" "f", Edge "f" "g"]@@ -148,8 +140,8 @@    describe "configuring number of cores" $ parallel $     it "is possible to configure number of cores" $ do-      results <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      results <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         numCpus1 <- Souffle.getNumThreads prog         Souffle.setNumThreads prog 4         numCpus2 <- Souffle.getNumThreads prog@@ -159,9 +151,9 @@       results `shouldBe` (1, 4, 2)    describe "findFact" $ parallel $ do-    it "returns Nothing if no matching fact was found" $ do-      (edge, reachable) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+    it "returns Nothing in case no matching fact was found" $ do+      (edge, reachable) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         e <- Souffle.findFact prog $ Edge "c" "d"         r <- Souffle.findFact prog $ Reachable "d" "e"@@ -169,9 +161,9 @@       edge `shouldBe` Nothing       reachable `shouldBe` Nothing -    it "returns Just the fact if matching fact was found" $ do-      (edge, reachable) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+    it "returns Just the fact in case matching fact was found" $ do+      (edge, reachable) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         e <- Souffle.findFact prog $ Edge "a" "b"         r <- Souffle.findFact prog $ Reachable "a" "c"

@@ -0,0 +1,31 @@++{-# LANGUAGE DataKinds, TypeFamilies, DeriveGeneric, DeriveAnyClass #-}++module Test.Language.Souffle.Experimental.Fixtures+  ( module Test.Language.Souffle.Experimental.Fixtures+  ) where++import GHC.Generics+import Language.Souffle.Class+import Language.Souffle.Experimental++data CompiledProgram = CompiledProgram++instance Program CompiledProgram where+  type ProgramFacts CompiledProgram = [Edge, Reachable]+  programName = const "compiledprogram"++data Edge = Edge String String+  deriving (Generic, Marshal, FactMetadata)++data Reachable = Reachable String String+  deriving (Eq, Show, Generic, Marshal, FactMetadata)++instance Fact Edge where+  type FactDirection Edge = 'Input+  factName = const "edge"++instance Fact Reachable where+  type FactDirection Reachable = 'Output+  factName = const "reachable"+

@@ -0,0 +1,21 @@++{-# LANGUAGE TypeApplications, TemplateHaskell #-}+module Test.Language.Souffle.Experimental.FixturesCompiled () where++-- NOTE: this module can't be grouped together with "Fixtures"+-- due to TemplateHaskell staging restriction.++import Test.Language.Souffle.Experimental.Fixtures+import Language.Souffle.Experimental++$(embedProgram CompiledProgram $ do+  Predicate edge <- predicateFor @Edge+  Predicate reachable <- predicateFor @Reachable+  a <- var "a"+  b <- var "b"+  c <- var "c"+  reachable(a, b) |- edge(a, b)+  reachable(a, b) |- do+    edge(a, c)+    reachable(c, b)+ )

@@ -0,0 +1,1117 @@++{-# LANGUAGE DeriveGeneric, DeriveAnyClass, TypeApplications, QuasiQuotes, TypeOperators #-}+{-# LANGUAGE DataKinds, TypeFamilies #-}++module Test.Language.Souffle.ExperimentalSpec+  ( module Test.Language.Souffle.ExperimentalSpec+  ) where++import qualified Test.Language.Souffle.Experimental.Fixtures as F+import Test.Hspec+import GHC.Generics+import Data.Int+import Data.Word+import Data.Maybe (fromJust)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import System.IO.Temp+import Language.Souffle.Experimental+import Language.Souffle.Class+import Language.Souffle.Interpreted as I+import Language.Souffle.Compiled as C+import NeatInterpolation+++data Point = Point { x :: Int32, y :: Int32 }+  deriving (Generic, Marshal, FactMetadata)++newtype IntFact = IntFact Int32+  deriving (Generic, Marshal, FactMetadata)++newtype UnsignedFact = UnsignedFact Word32+  deriving (Generic, Marshal, FactMetadata)++newtype FloatFact = FloatFact Float+  deriving (Generic, Marshal, FactMetadata)++data TextFact = TextFact T.Text TL.Text+  deriving (Generic, Marshal, FactMetadata)++data Triple = Triple String Int32 String+  deriving (Generic, Marshal, FactMetadata)++newtype Vertex = Vertex String+  deriving (Generic, Marshal, FactMetadata)++data Edge = Edge String String+  deriving (Generic, Marshal, FactMetadata)++data Reachable = Reachable String String+  deriving (Eq, Show, Generic, Marshal, FactMetadata)++newtype BTreeFact = BTreeFact Int32+  deriving (Generic, Marshal)++newtype BrieFact = BrieFact Int32+  deriving (Generic, Marshal)++data EqRelFact = EqRelFact Int32 Int32+  deriving (Generic, Marshal)++data DSLProgram = DSLProgram++instance Program DSLProgram where+  type ProgramFacts DSLProgram =+    [ Point+    , IntFact+    , FloatFact+    , UnsignedFact+    , TextFact+    , BTreeFact+    , BrieFact+    , EqRelFact+    , Triple+    , Vertex+    , Edge+    , Reachable+    ]+  programName = const "dslprogram"++instance Fact Point where+  type FactDirection Point = 'Input+  factName = const "point"+instance Fact IntFact where+  type FactDirection IntFact = 'Input+  factName = const "intfact"+instance Fact FloatFact where+  type FactDirection FloatFact = 'Input+  factName = const "floatfact"+instance Fact UnsignedFact where+  type FactDirection UnsignedFact = 'Input+  factName = const "unsignedfact"+instance Fact TextFact where+  type FactDirection TextFact = 'InputOutput+  factName = const "textfact"+instance Fact Triple where+  type FactDirection Triple = 'Internal+  factName = const "triple"+instance Fact Vertex where+  type FactDirection Vertex = 'Output+  factName = const "vertex"+instance Fact Edge where+  type FactDirection Edge = 'Input+  factName = const "edge"+instance Fact Reachable where+  type FactDirection Reachable = 'Output+  factName = const "reachable"+instance Fact BTreeFact where+  type FactDirection BTreeFact = 'Internal+  factName = const "btreefact"+instance Fact BrieFact where+  type FactDirection BrieFact = 'Internal+  factName = const "briefact"+instance Fact EqRelFact where+  type FactDirection EqRelFact = 'Input+  factName = const "eqrelfact"+instance FactMetadata BTreeFact where+  factOpts = const $ Metadata BTree NoInline+instance FactMetadata BrieFact where+  factOpts = const $ Metadata Brie Inline+instance FactMetadata EqRelFact where+  factOpts = const $ Metadata EqRel NoInline++spec :: Spec+spec = describe "Souffle DSL" $ parallel $ do+  describe "code generation" $ parallel $ do+    let prog ==> txt =+          let rendered = T.strip $ render DSLProgram prog+              expected = T.strip txt+          in rendered `shouldBe` expected++    it "can render an empty program" $+      render DSLProgram (pure ()) `shouldBe` ""++    it "can render a program with an input type definition" $ do+      let prog = do+            Predicate _ <- predicateFor @Edge+            pure ()+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        |]++    it "can render a program with an output type definition" $ do+      let prog = do+            Predicate _ <- predicateFor @Reachable+            pure ()+      prog ==> [text|+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        |]++    it "can render a program with type declared both as in- and output" $ do+      let prog = do+            Predicate _ <- predicateFor @TextFact+            pure ()+      prog ==> [text|+        .decl textfact(t1: symbol, t2: symbol)+        .input textfact+        .output textfact+        |]++    it "can render a program with type declared and only used internally" $ do+      let prog = do+            Predicate _ <- predicateFor @Triple+            pure ()+      prog ==> [text|+        .decl triple(t1: symbol, t2: number, t3: symbol)+        |]++    it "renders type declaration based on type info" $ do+      let prog = do+            Predicate _ <- predicateFor @IntFact+            Predicate _ <- predicateFor @UnsignedFact+            Predicate _ <- predicateFor @FloatFact+            Predicate _ <- predicateFor @Triple+            Predicate _ <- predicateFor @BTreeFact+            Predicate _ <- predicateFor @BrieFact+            Predicate _ <- predicateFor @EqRelFact+            pure ()+      prog ==> [text|+        .decl intfact(t1: number)+        .input intfact+        .decl unsignedfact(t1: unsigned)+        .input unsignedfact+        .decl floatfact(t1: float)+        .input floatfact+        .decl triple(t1: symbol, t2: number, t3: symbol)+        .decl btreefact(t1: number) btree+        .decl briefact(t1: number) brie inline+        .decl eqrelfact(t1: number, t2: number) eqrel+        .input eqrelfact+        |]++    it "uses record accessors as attribute names in type declaration if provided" $ do+      let prog = do+            Predicate _ <- predicateFor @Point+            pure ()+      prog ==> [text|+        .decl point(x: number, y: number)+        .input point+        |]++    it "can render facts" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate triple <- predicateFor @Triple+            Predicate txt <- predicateFor @TextFact+            Predicate unsigned <- predicateFor @UnsignedFact+            Predicate float <- predicateFor @FloatFact+            edge("a", "b")+            triple("cde", 1000, "fgh")+            txt("ijk", "lmn")+            unsigned(42)+            float(42.42)+            float(0.01)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl triple(t1: symbol, t2: number, t3: symbol)+        .decl textfact(t1: symbol, t2: symbol)+        .input textfact+        .output textfact+        .decl unsignedfact(t1: unsigned)+        .input unsignedfact+        .decl floatfact(t1: float)+        .input floatfact+        edge("a", "b").+        triple("cde", 1000, "fgh").+        textfact("ijk", "lmn").+        unsignedfact(42).+        floatfact(42.42).+        floatfact(0.01).+        |]++    it "can render a relation with a single rule" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            reachable(a, b) |- edge(a, b)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, b).+        |]++    it "can render a relation with multiple rules" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            reachable(a, b) |- do+              edge(a, a)+              edge(b, b)+              edge(a, b)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, a),+          edge(b, b),+          edge(a, b).+        |]++    it "can render a relation containing a wildcard" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate vertex <- predicateFor @Vertex+            a <- var "a"+            vertex(a) |- do+              edge(a, __)+              edge(__, a)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl vertex(t1: symbol)+        .output vertex+        vertex(a) :-+          edge(a, _),+          edge(_, a).+        |]++    it "can render a relation with a logical or in the rule block" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            reachable(a, b) |- do+              let rules1 = do+                    edge(a, a)+                    edge(b, b)+                  rules2 = do+                    edge(a, b)+                    edge(b, a)+              rules1 \/ rules2+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, a),+          edge(b, b);+          edge(a, b),+          edge(b, a).+        |]++    it "can render a relation with multiple clauses" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            c <- var "c"+            reachable(a, b) |- edge(a, b)+            reachable(a, b) |- do+              edge(a, c)+              reachable(c, b)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, b).+        reachable(a, b) :-+          edge(a, c),+          reachable(c, b).+        |]++    it "can render a mix of and- and or- clauses correctly" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            c <- var "c"+            reachable(a, b) |- do+              edge(a, c) \/ edge(a, b)+              reachable(c, b)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          (edge(a, c);+          edge(a, b)),+          reachable(c, b).+        |]++    it "discards empty alternative blocks" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            c <- var "c"+            reachable(a, b) |- do+              pure () \/ edge(a, c)+              reachable(c, b)+            reachable(a, b) |- do+              edge(a,c) \/ pure ()+              reachable(c, b)+            reachable(a, b) |- do+              pure () \/ do+                edge(a, c)+                reachable(c, b)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, c),+          reachable(c, b).+        reachable(a, b) :-+          edge(a, c),+          reachable(c, b).+        reachable(a, b) :-+          edge(a, c),+          reachable(c, b).+        |]++    it "discards rules with empty rule blocks completely" $ do+      let prog = do+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            reachable(a, b) |-+              pure ()+            reachable(a, b) |- do+              pure () \/ pure ()+              pure ()+      prog ==> [text|+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        |]++    it "discards empty negations" $ do+      let prog = do+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            reachable(a, b) |- do+              not' $ pure ()+      prog ==> [text|+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        |]++    it "allows generically describing predicate relations" $ do+      -- NOTE: type signature not required, but it results in more clear type errors+      -- and can serve as documentation.+      let transitive :: forall prog p1 p2 t. Structure p1 ~ Structure p2+                      => Structure p1 ~ '[t, t]+                      => Predicate p1 -> Predicate p2 -> DSL prog 'Definition ()+          transitive (Predicate p1) (Predicate p2) = do+            a <- var "a"+            b <- var "b"+            c <- var "c"+            p1(a, b) |- p2(a, b)+            p1(a, b) |- do+              p2(a, c)+              p1(c, b)+          prog = do+            edge <- predicateFor @Edge+            reachable <- predicateFor @Reachable+            transitive reachable edge+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, b) :-+          edge(a, b).+        reachable(a, b) :-+          edge(a, c),+          reachable(c, b).+        |]++    it "can render logical negation in rule block" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate triple <- predicateFor @Triple+            a <- var "a"+            b <- var "b"+            c <- var "c"+            triple(a, b, c) |- do+              not' $ edge(a,c)+            triple(a, b, c) |- do+              not' $ do+                edge(a,a)+                edge(c,c)+            triple(a, b, c) |- do+              not' $ edge(a,a) \/ edge(c,c)+            triple(a, b, c) |- do+              not' $ not' $ edge(a,a)+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl triple(t1: symbol, t2: number, t3: symbol)+        triple(a, b, c) :-+          !edge(a, c).+        triple(a, b, c) :-+          !(edge(a, a),+          edge(c, c)).+        triple(a, b, c) :-+          !(edge(a, a);+          edge(c, c)).+        triple(a, b, c) :-+          !!edge(a, a).+        |]++    it "generates unique var names to avoid name collisions" $ do+      let prog = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            a' <- var "a"+            reachable(a, a') |- edge(a, a')+      prog ==> [text|+        .decl edge(t1: symbol, t2: symbol)+        .input edge+        .decl reachable(t1: symbol, t2: symbol)+        .output reachable+        reachable(a, a_1) :-+          edge(a, a_1).+        |]++    describe "operators" $ parallel $ do+      -- TODO: check for number, unsigned, float; check underscore is not allowed+      describe "arithmetic" $ parallel $ do+        it "supports +" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                int(10 + 32)+                int(10 + 80 + 10)+                unsigned(10 + 32)+                float(10.12 + 31.88)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(10 + 32).+            intfact(10 + 80 + 10).+            unsignedfact(10 + 32).+            floatfact(10.12 + 31.88).+            |]++        it "supports *" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                int(10 * 32)+                int(10 * 80 * 10)+                unsigned(10 * 32)+                float(10.12 * 31.88)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(10 * 32).+            intfact(10 * 80 * 10).+            unsignedfact(10 * 32).+            floatfact(10.12 * 31.88).+            |]++        it "supports binary -" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                int(10 - 32)+                int(10 - 80 - 10)+                unsigned(10 - 32)+                float(10.12 - 31.88)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(10 - 32).+            intfact(10 - 80 - 10).+            unsignedfact(10 - 32).+            floatfact(10.12 - 31.88).+            |]++        it "supports unary -" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate float <- predicateFor @FloatFact+                int(-42)+                int(-100)+                float(-13.37)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(-42).+            intfact(-100).+            floatfact(-13.37).+            |]++        it "supports /" $ do+          let prog = do+                Predicate float <- predicateFor @FloatFact+                float(13.37 / 0.01)+          prog ==> [text|+            .decl floatfact(t1: float)+            .input floatfact+            floatfact(13.37 / 0.01).+            |]++        it "supports ^" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                int(10 .^ 32)+                int(10 .^ 80 .^ 10)+                unsigned(10 .^ 32)+                float(42.42 .^ 2)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(10 ^ 32).+            intfact(10 ^ 80 ^ 10).+            unsignedfact(10 ^ 32).+            floatfact(42.42 ^ 2.0).+            |]++        it "supports %" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 .% 32)+                int(10 .% 80 .% 10)+                unsigned(10 .% 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 % 32).+            intfact(10 % 80 % 10).+            unsignedfact(10 % 32).+            |]++      describe "logical operators" $ parallel $ do+        it "supports band" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 `band` 32)+                int(10 `band` 80 `band` 10)+                unsigned(10 `band` 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 band 32).+            intfact(10 band 80 band 10).+            unsignedfact(10 band 32).+            |]++        it "supports bor" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 `bor` 32)+                int(10 `bor` 80 `bor` 10)+                unsigned(10 `bor` 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 bor 32).+            intfact(10 bor 80 bor 10).+            unsignedfact(10 bor 32).+            |]++        it "supports bxor" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 `bxor` 32)+                int(10 `bxor` 80 `bxor` 10)+                unsigned(10 `bxor` 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 bxor 32).+            intfact(10 bxor 80 bxor 10).+            unsignedfact(10 bxor 32).+            |]++        it "supports land" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 `land` 32)+                int(10 `land` 80 `land` 10)+                unsigned(10 `land` 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 land 32).+            intfact(10 land 80 land 10).+            unsignedfact(10 land 32).+            |]++        it "supports lor" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                int(10 `lor` 32)+                int(10 `lor` 80 `lor` 10)+                unsigned(10 `lor` 32)+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            intfact(10 lor 32).+            intfact(10 lor 80 lor 10).+            unsignedfact(10 lor 32).+            |]++      describe "comparisons and equality, inequality" $ parallel $ do+        -- NOTE: the following generated programs are not correct+        -- since vars are not grounded (but is done to keep tests succinct)+        it "supports <" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                a <- var "a"+                b <- var "b"+                c <- var "c"+                int(a) |- a .< 10+                unsigned(b) |- b .< 10+                float(c) |- c .< 10.1+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(a) :-+              a < 10.+            unsignedfact(b) :-+              b < 10.+            floatfact(c) :-+              c < 10.1.+            |]++        it "supports <=" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                a <- var "a"+                b <- var "b"+                c <- var "c"+                int(a) |- a .<= 10+                unsigned(b) |- b .<= 10+                float(c) |- c .<= 10.1+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(a) :-+              a <= 10.+            unsignedfact(b) :-+              b <= 10.+            floatfact(c) :-+              c <= 10.1.+            |]++        it "supports >" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                a <- var "a"+                b <- var "b"+                c <- var "c"+                int(a) |- a .> 10+                unsigned(b) |- b .> 10+                float(c) |- c .> 10.1+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(a) :-+              a > 10.+            unsignedfact(b) :-+              b > 10.+            floatfact(c) :-+              c > 10.1.+            |]++        it "supports >=" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                a <- var "a"+                b <- var "b"+                c <- var "c"+                int(a) |- a .>= 10+                unsigned(b) |- b .>= 10+                float(c) |- c .>= 10.1+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            intfact(a) :-+              a >= 10.+            unsignedfact(b) :-+              b >= 10.+            floatfact(c) :-+              c >= 10.1.+            |]++        it "supports =" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                Predicate vertex <- predicateFor @Vertex+                a <- var "a"+                b <- var "b"+                c <- var "c"+                d <- var "d"+                int(a) |- a .= 10+                unsigned(b) |- b .= 10+                float(c) |- c .= 10.1+                vertex(d) |- d .= "abc"+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            .decl vertex(t1: symbol)+            .output vertex+            intfact(a) :-+              a = 10.+            unsignedfact(b) :-+              b = 10.+            floatfact(c) :-+              c = 10.1.+            vertex(d) :-+              d = "abc".+            |]++        it "supports !=" $ do+          let prog = do+                Predicate int <- predicateFor @IntFact+                Predicate unsigned <- predicateFor @UnsignedFact+                Predicate float <- predicateFor @FloatFact+                Predicate vertex <- predicateFor @Vertex+                a <- var "a"+                b <- var "b"+                c <- var "c"+                d <- var "d"+                int(a) |- a .!= 10+                unsigned(b) |- b .!= 10+                float(c) |- c .!= 10.1+                vertex(d) |- d .!= "abc"+          prog ==> [text|+            .decl intfact(t1: number)+            .input intfact+            .decl unsignedfact(t1: unsigned)+            .input unsignedfact+            .decl floatfact(t1: float)+            .input floatfact+            .decl vertex(t1: symbol)+            .output vertex+            intfact(a) :-+              a != 10.+            unsignedfact(b) :-+              b != 10.+            floatfact(c) :-+              c != 10.1.+            vertex(d) :-+              d != "abc".+            |]++    describe "functors" $ parallel $ do+      it "supports max" $ do+        let prog = do+              Predicate int <- predicateFor @IntFact+              Predicate unsigned <- predicateFor @UnsignedFact+              Predicate float <- predicateFor @FloatFact+              int(max' 10 32)+              int(max' (max' 10 80) 10)+              unsigned(max' 10 32)+              float(max' 42.42 2)+        prog ==> [text|+          .decl intfact(t1: number)+          .input intfact+          .decl unsignedfact(t1: unsigned)+          .input unsignedfact+          .decl floatfact(t1: float)+          .input floatfact+          intfact(max(10, 32)).+          intfact(max(max(10, 80), 10)).+          unsignedfact(max(10, 32)).+          floatfact(max(42.42, 2.0)).+          |]++      it "supports min" $ do+        let prog = do+              Predicate int <- predicateFor @IntFact+              Predicate unsigned <- predicateFor @UnsignedFact+              Predicate float <- predicateFor @FloatFact+              int(min' 10 32)+              int(min' (min' 10 80) 10)+              unsigned(min' 10 32)+              float(min' 42.42 2)+        prog ==> [text|+          .decl intfact(t1: number)+          .input intfact+          .decl unsignedfact(t1: unsigned)+          .input unsignedfact+          .decl floatfact(t1: float)+          .input floatfact+          intfact(min(10, 32)).+          intfact(min(min(10, 80), 10)).+          unsignedfact(min(10, 32)).+          floatfact(min(42.42, 2.0)).+          |]++      it "supports cat" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              vertex(cat "abc" "def")+              vertex(cat "abc" $ cat "def" "ghi")+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          vertex(cat("abc", "def")).+          vertex(cat("abc", cat("def", "ghi"))).+          |]++      it "supports contains" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              b <- var "b"+              int(0) |- do+                vertex(a)+                vertex(b)+                contains a b+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          intfact(0) :-+            vertex(a),+            vertex(b),+            contains(a, b).+          |]++      it "supports match" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              int(0) |- do+                vertex(a)+                match "*.a" a+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          intfact(0) :-+            vertex(a),+            match("*.a", a).+          |]++      it "supports ord" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              int(ord a) |-+                vertex(a)+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          intfact(ord(a)) :-+            vertex(a).+          |]++      it "supports strlen" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              int(strlen a) |-+                vertex(a)+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          intfact(strlen(a)) :-+            vertex(a).+          |]++      it "supports substr" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              a <- var "a"+              vertex(a) |-+                a .= substr "Hello" 1 3+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          vertex(a) :-+            a = substr("Hello", 1, 3).+          |]+++      it "supports to_number" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              int(to_number a) |-+                vertex(a)+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          intfact(to_number(a)) :-+            vertex(a).+          |]++      it "supports to_string" $ do+        let prog = do+              Predicate vertex <- predicateFor @Vertex+              Predicate int <- predicateFor @IntFact+              a <- var "a"+              vertex(to_string a) |-+                int(a)+        prog ==> [text|+          .decl vertex(t1: symbol)+          .output vertex+          .decl intfact(t1: number)+          .input intfact+          vertex(to_string(a)) :-+            intfact(a).+          |]++  describe "running DSL code directly " $ parallel $ do+    it "can run DSL with default config in interpreted mode" $ do+      let ast = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            c <- var "c"+            reachable(a, b) |- edge(a, b)+            reachable(a, b) |- do+              edge(a, c)+              reachable(c, b)+          action handle = do+            let prog = fromJust handle+            I.addFacts prog [Edge "a" "b", Edge "b" "c"]+            I.run prog+            I.getFacts prog+      rs <- runSouffleInterpreted DSLProgram ast action+      rs `shouldBe` [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]++    it "can run DSL with modified config in interpreted mode" $ do+      tmpDir <- getCanonicalTemporaryDirectory+      souffleHsDir <- createTempDirectory tmpDir "souffle-haskell"+      cfg <- I.defaultConfig+      let config = cfg { I.cfgDatalogDir = souffleHsDir }+          ast = do+            Predicate edge <- predicateFor @Edge+            Predicate reachable <- predicateFor @Reachable+            a <- var "a"+            b <- var "b"+            c <- var "c"+            reachable(a, b) |- edge(a, b)+            reachable(a, b) |- do+              edge(a, c)+              reachable(c, b)+          action handle = do+            let prog = fromJust handle+            I.addFacts prog [Edge "a" "b", Edge "b" "c"]+            I.run prog+            I.getFacts prog+      rs <- runSouffleInterpretedWith config DSLProgram ast action+      rs `shouldBe` [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]++    it "can run DSL in compiled mode" $ do+      rs <- C.runSouffle F.CompiledProgram $ \handle -> do+        let prog = fromJust handle+        C.addFacts prog [F.Edge "a" "b", F.Edge "b" "c"]+        C.run prog+        C.getFacts prog+      rs `shouldBe` [F.Reachable "b" "c", F.Reachable "a" "c", F.Reachable "a" "b"]+

@@ -7,7 +7,6 @@  import Test.Hspec import GHC.Generics-import Control.Monad (join) import Data.Maybe import Control.Monad.IO.Class (liftIO) import System.Directory@@ -30,9 +29,11 @@   deriving (Eq, Show, Generic)  instance Souffle.Fact Edge where+  type FactDirection Edge = 'Souffle.InputOutput   factName = const "edge"  instance Souffle.Fact Reachable where+  type FactDirection Reachable = 'Souffle.Output   factName = const "reachable"  instance Souffle.Marshal Edge@@ -58,115 +59,91 @@ spec :: Spec spec = describe "Souffle API" $ parallel $ do   describe "init" $ parallel $ do-    it "returns nothing if it cannot load a souffle program" $ do-      prog <- Souffle.runSouffle (Souffle.init BadPath)+    it "returns nothing in case it cannot load a souffle program" $ do+      prog <- Souffle.runSouffle BadPath pure       isJust prog `shouldBe` False -    it "returns just the program if it can load a souffle program" $ do-      prog <- Souffle.runSouffle $ do-        handle <- fromJust <$> Souffle.init Path-        Souffle.cleanup handle-        pure $ Just handle+    it "returns just the program in case it can load a souffle program" $ do+      prog <- Souffle.runSouffle Path pure       isJust prog `shouldBe` True    describe "getFacts" $ parallel $ do     it "can retrieve facts as a list" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      (edges, reachables) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog-        Souffle.cleanup prog         pure (es , rs)       edges `shouldBe` [Edge "a" "b", Edge "b" "c"]       reachables `shouldBe` [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]      it "can retrieve facts as a vector" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      (edges, reachables) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog-        Souffle.cleanup prog         pure (es , rs)       edges `shouldBe` V.fromList [Edge "a" "b", Edge "b" "c"]       reachables `shouldBe` V.fromList [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]      it "can retrieve facts as an array" $ do-      (edges, reachables) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      (edges, reachables) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog-        Souffle.cleanup prog         pure (es , rs)       edges `shouldBe` A.listArray (0 :: Int, 1) [Edge "a" "b", Edge "b" "c"]       reachables `shouldBe` A.listArray (0 :: Int, 2) [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"] -    it "returns no facts if program hasn't run yet" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path-        results <- Souffle.getFacts prog-        Souffle.cleanup prog-        pure results+    it "returns no facts in case program hasn't run yet" $ do+      edges <- Souffle.runSouffle Path $ Souffle.getFacts . fromJust       edges `shouldBe` ([] :: [Edge])      it "can retrieve facts from custom output directory" $ do       cfg <- Souffle.defaultConfig       tmp <- getTestTemporaryDirectory-      (edges, reachables) <- Souffle.runSouffleWith (cfg { Souffle.cfgOutputDir = Just tmp }) $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      let cfg' = cfg { Souffle.cfgOutputDir = Just tmp }+      (edges, reachables) <- Souffle.runSouffleWith cfg' PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         es <- Souffle.getFacts prog         rs <- Souffle.getFacts prog-        Souffle.cleanup prog         pure (es , rs)       edges `shouldBe` V.fromList [Edge "a" "b", Edge "b" "c"]       reachables `shouldBe` V.fromList [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]       outputDirExist <- doesDirectoryExist tmp-      outputDirExist `shouldBe` False+      outputDirExist `shouldBe` True  -- should not be automatically cleaned up    describe "addFact" $ parallel $ do     it "adds a fact" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      edges <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.addFact prog $ Edge "e" "f"         Souffle.run prog-        edges <- Souffle.getFacts prog-        Souffle.cleanup prog-        pure edges+        Souffle.getFacts prog       edges `shouldBe` [Edge "a" "b", Edge "b" "c", Edge "e" "f"] -    -- NOTE: this is different compared to compiled version (bug in Souffle?)-    it "can not add a fact if it is not marked as input" $ do-      reachables <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput-        Souffle.addFact prog $ Reachable "e" "f"-        Souffle.run prog-        reachables <- Souffle.getFacts prog-        Souffle.cleanup prog-        pure reachables-      reachables `shouldBe`-        [ Reachable "a" "b", Reachable "a" "c", Reachable "b" "c" ]-     it "adds a fact to a custom input directory" $ do       cfg <- Souffle.defaultConfig       tmp <- getTestTemporaryDirectory-      join $ Souffle.runSouffleWith (cfg { Souffle.cfgFactDir = Just tmp }) $ do -- Souffle-        prog <- fromJust <$> Souffle.init Path+      let cfg' = cfg { Souffle.cfgFactDir = Just tmp }+      Souffle.runSouffleWith cfg' Path $ \handle -> do+        let prog = fromJust handle         Souffle.addFact prog $ Edge "e" "f"         Souffle.run prog         edges <- Souffle.getFacts prog-        entries <- liftIO $ listDirectory tmp-        Souffle.cleanup prog-        pure $ do -- IO+        liftIO $ do+          entries <- listDirectory tmp           edges `shouldBe` [Edge "a" "b", Edge "b" "c", Edge "e" "f"]           length entries `shouldNotBe` 0    describe "addFacts" $ parallel $     it "can add multiple facts at once" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      edges <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.addFacts prog [Edge "e" "f", Edge "f" "g"]         Souffle.run prog         Souffle.getFacts prog@@ -174,25 +151,22 @@    describe "run" $ parallel $ do     it "is OK to run a program multiple times" $ do-      edges <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      edges <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         Souffle.run prog-        facts <- Souffle.getFacts prog-        Souffle.cleanup prog-        pure facts+        Souffle.getFacts prog       edges `shouldBe` [Reachable "a" "b", Reachable "a" "c", Reachable "b" "c"]      it "discovers new facts after running with new facts" $ do-      (reachablesBefore, reachablesAfter) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      (reachablesBefore, reachablesAfter) <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         Souffle.addFacts prog [Edge "c" "d"]         Souffle.run prog         rs1 <- Souffle.getFacts prog         Souffle.addFacts prog [Edge "b" "e"]         Souffle.run prog         rs2 <- Souffle.getFacts prog-        Souffle.cleanup prog         pure (rs1, rs2)       reachablesBefore `shouldBe`         [ Reachable "a" "b", Reachable "a" "c", Reachable "a" "d"@@ -203,20 +177,19 @@         , Reachable "b" "e", Reachable "c" "d" ]      it "saves stdout and stderr output after run" $ do-      (stdout, stderr) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+      (stdout, stderr) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         out <- Souffle.souffleStdOut prog         err <- Souffle.souffleStdErr prog-        Souffle.cleanup prog         pure (out, err)       stdout `shouldBe` Just ""       stderr `shouldBe` Just ""    describe "configuring number of cores" $ parallel $     it "is possible to configure number of cores" $ do-      results <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init Path+      results <- Souffle.runSouffle Path $ \handle -> do+        let prog = fromJust handle         numCpus1 <- Souffle.getNumThreads prog         Souffle.setNumThreads prog 4         numCpus2 <- Souffle.getNumThreads prog@@ -226,9 +199,9 @@       results `shouldBe` (1, 4, 2)    describe "findFact" $ parallel $ do-    it "returns Nothing if no matching fact was found" $ do-      (edge, reachable) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+    it "returns Nothing in case no matching fact was found" $ do+      (edge, reachable) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         e <- Souffle.findFact prog $ Edge "c" "d"         r <- Souffle.findFact prog $ Reachable "d" "e"@@ -236,9 +209,9 @@       edge `shouldBe` Nothing       reachable `shouldBe` Nothing -    it "returns Just the fact if matching fact was found" $ do-      (edge, reachable) <- Souffle.runSouffle $ do-        prog <- fromJust <$> Souffle.init PathNoInput+    it "returns Just the fact in case matching fact was found" $ do+      (edge, reachable) <- Souffle.runSouffle PathNoInput $ \handle -> do+        let prog = fromJust handle         Souffle.run prog         e <- Souffle.findFact prog $ Edge "a" "b"         r <- Souffle.findFact prog $ Reachable "a" "c"

@@ -100,21 +100,27 @@   deriving (Eq, Show, Generic)  instance Souffle.Fact StringFact where+  type FactDirection StringFact = 'Souffle.InputOutput   factName = const "string_fact"  instance Souffle.Fact TextFact where+  type FactDirection TextFact = 'Souffle.InputOutput   factName = const "string_fact"  instance Souffle.Fact LazyTextFact where+  type FactDirection LazyTextFact = 'Souffle.InputOutput   factName = const "string_fact"  instance Souffle.Fact Int32Fact where+  type FactDirection Int32Fact = 'Souffle.InputOutput   factName = const "number_fact"  instance Souffle.Fact Word32Fact where+  type FactDirection Word32Fact = 'Souffle.InputOutput   factName = const "unsigned_fact"  instance Souffle.Fact FloatFact where+  type FactDirection FloatFact = 'Souffle.InputOutput   factName = const "float_fact"  instance Souffle.Marshal StringFact@@ -125,12 +131,14 @@ instance Souffle.Marshal FloatFact  instance Souffle.Program RoundTrip where-  type ProgramFacts RoundTrip = +  type ProgramFacts RoundTrip =     [StringFact, TextFact, LazyTextFact, Int32Fact, Word32Fact, FloatFact]   programName = const "round_trip"  type RoundTripAction-  = forall a. (Souffle.Fact a, Souffle.ContainsFact RoundTrip a)+  = forall a. Souffle.Fact a+  => Souffle.ContainsInputFact RoundTrip a+  => Souffle.ContainsOutputFact RoundTrip a   => a -> PropertyT IO a  spec :: Spec@@ -173,7 +181,6 @@             fact' <- run fact             fact === fact' -          {- TODO: enable this test once souffle floating point conversions are fixed           it "can serialize and deserialize Float values" $ hedgehog $ do             let epsilon = 1e-6                 fmin = -1e9@@ -182,20 +189,17 @@             let fact = FloatFact x             FloatFact x' <- run fact             (abs (x' - x) < epsilon) === True-          -}      describe "interpreted mode" $ parallel $-      roundTripTests $ \fact -> liftIO $ Interpreted.runSouffle $ do-        handle <- fromJust <$> Interpreted.init RoundTrip-        Interpreted.addFact handle fact-        Interpreted.run handle-        fact' <- Prelude.head <$> Interpreted.getFacts handle-        Interpreted.cleanup handle-        pure fact'+      roundTripTests $ \fact -> liftIO $ Interpreted.runSouffle RoundTrip $ \handle -> do+        let prog = fromJust handle+        Interpreted.addFact prog fact+        Interpreted.run prog+        Prelude.head <$> Interpreted.getFacts prog      describe "compiled mode" $ parallel $-      roundTripTests $ \fact -> liftIO $ Compiled.runSouffle $ do-        handle <- fromJust <$> Compiled.init RoundTrip-        Compiled.addFact handle fact-        Compiled.run handle-        Prelude.head <$> Compiled.getFacts handle+      roundTripTests $ \fact -> liftIO $ Compiled.runSouffle RoundTrip $ \handle -> do+        let prog = fromJust handle+        Compiled.addFact prog fact+        Compiled.run prog+        Prelude.head <$> Compiled.getFacts prog