diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/lib/Language/Souffle/Class.hs b/lib/Language/Souffle/Class.hs --- a/lib/Language/Souffle/Class.hs +++ b/lib/Language/Souffle/Class.hs @@ -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 diff --git a/lib/Language/Souffle/Compiled.hs b/lib/Language/Souffle/Compiled.hs --- a/lib/Language/Souffle/Compiled.hs +++ b/lib/Language/Souffle/Compiled.hs @@ -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) diff --git a/lib/Language/Souffle/Experimental.hs b/lib/Language/Souffle/Experimental.hs new file mode 100644 --- /dev/null +++ b/lib/Language/Souffle/Experimental.hs @@ -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 . +-} +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 +-- . +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 +-- and this +-- . +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)" + ) + diff --git a/lib/Language/Souffle/Internal/Constraints.hs b/lib/Language/Souffle/Internal/Constraints.hs --- a/lib/Language/Souffle/Internal/Constraints.hs +++ b/lib/Language/Souffle/Internal/Constraints.hs @@ -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 diff --git a/lib/Language/Souffle/Interpreted.hs b/lib/Language/Souffle/Interpreted.hs --- a/lib/Language/Souffle/Interpreted.hs +++ b/lib/Language/Souffle/Interpreted.hs @@ -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) diff --git a/lib/Language/Souffle/Marshal.hs b/lib/Language/Souffle/Marshal.hs --- a/lib/Language/Souffle/Marshal.hs +++ b/lib/Language/Souffle/Marshal.hs @@ -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 #-} diff --git a/scripts/import_souffle_headers.hs b/scripts/import_souffle_headers.hs --- a/scripts/import_souffle_headers.hs +++ b/scripts/import_souffle_headers.hs @@ -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 diff --git a/souffle-haskell.cabal b/souffle-haskell.cabal --- a/souffle-haskell.cabal +++ b/souffle-haskell.cabal @@ -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 diff --git a/tests/Test/Language/Souffle/CompiledSpec.hs b/tests/Test/Language/Souffle/CompiledSpec.hs --- a/tests/Test/Language/Souffle/CompiledSpec.hs +++ b/tests/Test/Language/Souffle/CompiledSpec.hs @@ -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" diff --git a/tests/Test/Language/Souffle/Experimental/Fixtures.hs b/tests/Test/Language/Souffle/Experimental/Fixtures.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Language/Souffle/Experimental/Fixtures.hs @@ -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" + diff --git a/tests/Test/Language/Souffle/Experimental/FixturesCompiled.hs b/tests/Test/Language/Souffle/Experimental/FixturesCompiled.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Language/Souffle/Experimental/FixturesCompiled.hs @@ -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) + ) diff --git a/tests/Test/Language/Souffle/ExperimentalSpec.hs b/tests/Test/Language/Souffle/ExperimentalSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Language/Souffle/ExperimentalSpec.hs @@ -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"] + diff --git a/tests/Test/Language/Souffle/InterpretedSpec.hs b/tests/Test/Language/Souffle/InterpretedSpec.hs --- a/tests/Test/Language/Souffle/InterpretedSpec.hs +++ b/tests/Test/Language/Souffle/InterpretedSpec.hs @@ -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" diff --git a/tests/Test/Language/Souffle/MarshalSpec.hs b/tests/Test/Language/Souffle/MarshalSpec.hs --- a/tests/Test/Language/Souffle/MarshalSpec.hs +++ b/tests/Test/Language/Souffle/MarshalSpec.hs @@ -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