{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE DataKinds, FlexibleContexts, TypeFamilies, DerivingVia, InstanceSigs #-}

-- | This module provides an implementation for the `MonadSouffle` typeclass
--   defined in "Language.Souffle.Class".
--   It makes use of the Souffle interpreter and CSV files to offer an
--   implementation optimized for quick development speed compared to
--   "Language.Souffle.Compiled".
--
--   It is however __much__ slower so users are advised to switch over to
--   the compiled alternative once the prototyping phase is finished.
module Language.Souffle.Interpreted
  ( Program(..)
  , Fact(..)
  , Marshal(..)
  , Config(..)
  , Handle
  , SouffleM
  , MonadSouffle(..)
  , runSouffle
  , runSouffleWith
  , defaultConfig
  , cleanup
  ) where

import Prelude hiding (init)

import Control.DeepSeq (deepseq)
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.IORef
import Data.Foldable (traverse_)
import Data.List hiding (init)
import Data.Semigroup (Last(..))
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Vector as V
import Data.Word
import Language.Souffle.Class
import Language.Souffle.Marshal
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO (hGetContents)
import System.IO.Temp
import System.Process
import Text.Printf


-- | A monad for executing Souffle-related actions in.
newtype SouffleM a
  = SouffleM (ReaderT Config IO a)
  deriving (a -> SouffleM b -> SouffleM a
(a -> b) -> SouffleM a -> SouffleM b
(forall a b. (a -> b) -> SouffleM a -> SouffleM b)
-> (forall a b. a -> SouffleM b -> SouffleM a) -> Functor SouffleM
forall a b. a -> SouffleM b -> SouffleM a
forall a b. (a -> b) -> SouffleM a -> SouffleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SouffleM b -> SouffleM a
$c<$ :: forall a b. a -> SouffleM b -> SouffleM a
fmap :: (a -> b) -> SouffleM a -> SouffleM b
$cfmap :: forall a b. (a -> b) -> SouffleM a -> SouffleM b
Functor, Functor SouffleM
a -> SouffleM a
Functor SouffleM =>
(forall a. a -> SouffleM a)
-> (forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b)
-> (forall a b c.
    (a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM b)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM a)
-> Applicative SouffleM
SouffleM a -> SouffleM b -> SouffleM b
SouffleM a -> SouffleM b -> SouffleM a
SouffleM (a -> b) -> SouffleM a -> SouffleM b
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
forall a. a -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM b
forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SouffleM a -> SouffleM b -> SouffleM a
$c<* :: forall a b. SouffleM a -> SouffleM b -> SouffleM a
*> :: SouffleM a -> SouffleM b -> SouffleM b
$c*> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
liftA2 :: (a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
<*> :: SouffleM (a -> b) -> SouffleM a -> SouffleM b
$c<*> :: forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
pure :: a -> SouffleM a
$cpure :: forall a. a -> SouffleM a
$cp1Applicative :: Functor SouffleM
Applicative, Applicative SouffleM
a -> SouffleM a
Applicative SouffleM =>
(forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM b)
-> (forall a. a -> SouffleM a)
-> Monad SouffleM
SouffleM a -> (a -> SouffleM b) -> SouffleM b
SouffleM a -> SouffleM b -> SouffleM b
forall a. a -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM b
forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SouffleM a
$creturn :: forall a. a -> SouffleM a
>> :: SouffleM a -> SouffleM b -> SouffleM b
$c>> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
>>= :: SouffleM a -> (a -> SouffleM b) -> SouffleM b
$c>>= :: forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
$cp1Monad :: Applicative SouffleM
Monad, Monad SouffleM
Monad SouffleM =>
(forall a. IO a -> SouffleM a) -> MonadIO SouffleM
IO a -> SouffleM a
forall a. IO a -> SouffleM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> SouffleM a
$cliftIO :: forall a. IO a -> SouffleM a
$cp1MonadIO :: Monad SouffleM
MonadIO)
  via (ReaderT Config IO)

-- | A helper data type for storing the configurable settings of the
--   interpreter.
--
--   - __cfgDatalogDir__: The directory where the datalog file(s) are located.
--   - __cfgSouffleBin__: The name of the souffle binary. Has to be available in
--   \$PATH or an absolute path needs to be provided. Note: Passing in `Nothing`
--   will fail to start up the interpreter in the `MonadSouffle.init` function.
data Config
  = Config
  { Config -> FilePath
cfgDatalogDir :: FilePath
  , Config -> Maybe FilePath
cfgSouffleBin :: Maybe FilePath
  } deriving Int -> Config -> ShowS
[Config] -> ShowS
Config -> FilePath
(Int -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> FilePath
$cshow :: Config -> FilePath
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show

-- | Retrieves the default config for the interpreter. These settings can
--   be overridden using record update syntax if needed.
--
--   By default, the settings will be configured as follows:
--
--   - __cfgDatalogDir__: Looks at environment variable \$DATALOG_DIR,
--   falls back to the current directory if not set.
--   - __cfgSouffleBin__: Looks at environment variable \$SOUFFLE_BIN,
--   or tries to locate the souffle binary using the which shell command
--   if the variable is not set.
defaultConfig :: MonadIO m => m Config
defaultConfig :: m Config
defaultConfig = IO Config -> m Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> m Config) -> IO Config -> m Config
forall a b. (a -> b) -> a -> b
$ do
  Maybe FilePath
dlDir <- FilePath -> IO (Maybe FilePath)
lookupEnv "DATALOG_DIR"
  Maybe (Last FilePath)
envSouffleBin <- (FilePath -> Last FilePath)
-> Maybe FilePath -> Maybe (Last FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Last FilePath
forall a. a -> Last a
Last (Maybe FilePath -> Maybe (Last FilePath))
-> IO (Maybe FilePath) -> IO (Maybe (Last FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv "SOUFFLE_BIN"
  Maybe (Last FilePath)
locatedBin <- (FilePath -> Last FilePath)
-> Maybe FilePath -> Maybe (Last FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Last FilePath
forall a. a -> Last a
Last (Maybe FilePath -> Maybe (Last FilePath))
-> IO (Maybe FilePath) -> IO (Maybe (Last FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe FilePath)
locateSouffle
  let souffleBin :: Maybe FilePath
souffleBin = Last FilePath -> FilePath
forall a. Last a -> a
getLast (Last FilePath -> FilePath)
-> Maybe (Last FilePath) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Last FilePath)
locatedBin Maybe (Last FilePath)
-> Maybe (Last FilePath) -> Maybe (Last FilePath)
forall a. Semigroup a => a -> a -> a
<> Maybe (Last FilePath)
envSouffleBin
  Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> Config
Config (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "." Maybe FilePath
dlDir) Maybe FilePath
souffleBin
{-# INLINABLE defaultConfig #-}

-- | Returns an IO action that will run the Souffle interpreter with
--   default settings (see `defaultConfig`).
runSouffle :: SouffleM a -> IO a
runSouffle :: SouffleM a -> IO a
runSouffle m :: SouffleM a
m = do
  Config
cfg <- IO Config
forall (m :: * -> *). MonadIO m => m Config
defaultConfig
  Config -> SouffleM a -> IO a
forall a. Config -> SouffleM a -> IO a
runSouffleWith Config
cfg SouffleM a
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 :: Config -> SouffleM a -> IO a
runSouffleWith cfg :: Config
cfg (SouffleM m :: ReaderT Config IO a
m) = ReaderT Config IO a -> Config -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Config IO a
m Config
cfg
{-# INLINABLE runSouffleWith #-}

-- | A datatype representing a handle to a datalog program.
--   The type parameter is used for keeping track of which program
--   type the handle belongs to for additional type safety.
newtype Handle prog = Handle (IORef HandleData)

-- | The data needed for the interpreter is the path where the souffle
--   executable can be found, and a template directory where the program
--   is stored.
data HandleData = HandleData
  { HandleData -> FilePath
soufflePath :: FilePath
  , HandleData -> FilePath
basePath    :: FilePath
  , HandleData -> FilePath
factPath    :: FilePath
  , HandleData -> FilePath
outputPath  :: FilePath
  , HandleData -> FilePath
datalogExec :: FilePath
  , HandleData -> Word64
noOfThreads :: Word64
  }

newtype IMarshal a = IMarshal (State [String] a)
  deriving
    ( a -> IMarshal b -> IMarshal a
(a -> b) -> IMarshal a -> IMarshal b
(forall a b. (a -> b) -> IMarshal a -> IMarshal b)
-> (forall a b. a -> IMarshal b -> IMarshal a) -> Functor IMarshal
forall a b. a -> IMarshal b -> IMarshal a
forall a b. (a -> b) -> IMarshal a -> IMarshal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IMarshal b -> IMarshal a
$c<$ :: forall a b. a -> IMarshal b -> IMarshal a
fmap :: (a -> b) -> IMarshal a -> IMarshal b
$cfmap :: forall a b. (a -> b) -> IMarshal a -> IMarshal b
Functor
    , Functor IMarshal
a -> IMarshal a
Functor IMarshal =>
(forall a. a -> IMarshal a)
-> (forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b)
-> (forall a b c.
    (a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal b)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal a)
-> Applicative IMarshal
IMarshal a -> IMarshal b -> IMarshal b
IMarshal a -> IMarshal b -> IMarshal a
IMarshal (a -> b) -> IMarshal a -> IMarshal b
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
forall a. a -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal b
forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: IMarshal a -> IMarshal b -> IMarshal a
$c<* :: forall a b. IMarshal a -> IMarshal b -> IMarshal a
*> :: IMarshal a -> IMarshal b -> IMarshal b
$c*> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
liftA2 :: (a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
<*> :: IMarshal (a -> b) -> IMarshal a -> IMarshal b
$c<*> :: forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
pure :: a -> IMarshal a
$cpure :: forall a. a -> IMarshal a
$cp1Applicative :: Functor IMarshal
Applicative
    , Applicative IMarshal
a -> IMarshal a
Applicative IMarshal =>
(forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal b)
-> (forall a. a -> IMarshal a)
-> Monad IMarshal
IMarshal a -> (a -> IMarshal b) -> IMarshal b
IMarshal a -> IMarshal b -> IMarshal b
forall a. a -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal b
forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> IMarshal a
$creturn :: forall a. a -> IMarshal a
>> :: IMarshal a -> IMarshal b -> IMarshal b
$c>> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
>>= :: IMarshal a -> (a -> IMarshal b) -> IMarshal b
$c>>= :: forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
$cp1Monad :: Applicative IMarshal
Monad
    , MonadState [String]
    )
  via (State [String])

popMarshalT :: MarshalM PopF a -> [String] -> a
popMarshalT :: MarshalM PopF a -> [FilePath] -> a
popMarshalT = IMarshal a -> [FilePath] -> a
forall a. IMarshal a -> [FilePath] -> a
runM (IMarshal a -> [FilePath] -> a)
-> (MarshalM PopF a -> IMarshal a)
-> MarshalM PopF a
-> [FilePath]
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. PopF x -> IMarshal x) -> MarshalM PopF a -> IMarshal a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> MarshalM f a -> m a
interpret forall x. PopF x -> IMarshal x
forall (m :: * -> *) a. MonadState [FilePath] m => PopF a -> m a
popAlgM where
  runM :: IMarshal a -> [FilePath] -> a
runM (IMarshal m :: State [FilePath] a
m) = State [FilePath] a -> [FilePath] -> a
forall s a. State s a -> s -> a
evalState State [FilePath] a
m
  popAlgM :: PopF a -> m a
popAlgM (PopStr f :: FilePath -> a
f) = do
    FilePath
str <- ([FilePath] -> (FilePath, [FilePath])) -> m FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\case
              [] -> FilePath -> (FilePath, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
              (h :: FilePath
h:t :: [FilePath]
t) -> (FilePath
h, [FilePath]
t))
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ FilePath -> a
f FilePath
str
  popAlgM (PopInt f :: Int32 -> a
f) = do
    Int32
int <- ([FilePath] -> (Int32, [FilePath])) -> m Int32
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\case
              [] -> FilePath -> (Int32, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
              (h :: FilePath
h:t :: [FilePath]
t) -> (FilePath -> Int32
forall a. Read a => FilePath -> a
read FilePath
h, [FilePath]
t))
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Int32 -> a
f Int32
int
{-# INLINABLE popMarshalT #-}

pushMarshalT :: MarshalM PushF a -> [String]
pushMarshalT :: MarshalM PushF a -> [FilePath]
pushMarshalT = IMarshal a -> [FilePath]
forall a. IMarshal a -> [FilePath]
runM (IMarshal a -> [FilePath])
-> (MarshalM PushF a -> IMarshal a)
-> MarshalM PushF a
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. PushF x -> IMarshal x) -> MarshalM PushF a -> IMarshal a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> MarshalM f a -> m a
interpret forall x. PushF x -> IMarshal x
forall (m :: * -> *) a. MonadState [FilePath] m => PushF a -> m a
pushAlgM where
  runM :: IMarshal a -> [FilePath]
runM (IMarshal m :: State [FilePath] a
m) = [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ State [FilePath] a -> [FilePath] -> [FilePath]
forall s a. State s a -> s -> s
execState State [FilePath] a
m []
  pushAlgM :: PushF a -> m a
pushAlgM (PushInt i :: Int32
i v :: a
v) = do
    ([FilePath] -> [FilePath]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int32 -> FilePath
forall a. Show a => a -> FilePath
show Int32
iFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
  pushAlgM (PushStr s :: FilePath
s v :: a
v) = do
    ([FilePath] -> [FilePath]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath
sFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
    a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
{-# INLINABLE pushMarshalT #-}


class Collect c where
  collect :: Marshal a => FilePath -> IO (c a)

instance Collect [] where
  collect :: FilePath -> IO [a]
collect factFile :: FilePath
factFile = do
    [[FilePath]]
factLines <- FilePath -> IO [[FilePath]]
readCSVFile FilePath
factFile
    let facts :: [a]
facts = ([FilePath] -> a) -> [[FilePath]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (MarshalM PopF a -> [FilePath] -> a
forall a. MarshalM PopF a -> [FilePath] -> a
popMarshalT MarshalM PopF a
forall a. Marshal a => MarshalM PopF a
pop) [[FilePath]]
factLines
    [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$! [a]
facts
  {-# INLINABLE collect #-}

instance Collect V.Vector where
  collect :: FilePath -> IO (Vector a)
collect factFile :: FilePath
factFile = [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> IO [a] -> IO (Vector a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> FilePath -> IO [a]
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
FilePath -> IO (c a)
collect FilePath
factFile
  {-# INLINABLE collect #-}

instance MonadSouffle SouffleM where
  type Handler SouffleM = Handle
  type CollectFacts SouffleM c = Collect c

  init :: forall prog. Program prog => prog -> SouffleM (Maybe (Handle prog))
  init :: prog -> SouffleM (Maybe (Handle prog))
init prg :: prog
prg = ReaderT Config IO (Maybe (Handle prog))
-> SouffleM (Maybe (Handle prog))
forall a. ReaderT Config IO a -> SouffleM a
SouffleM (ReaderT Config IO (Maybe (Handle prog))
 -> SouffleM (Maybe (Handle prog)))
-> ReaderT Config IO (Maybe (Handle prog))
-> SouffleM (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ prog -> ReaderT Config IO (Maybe FilePath)
forall prog.
Program prog =>
prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile prog
prg ReaderT Config IO (Maybe FilePath)
-> (Maybe FilePath -> ReaderT Config IO (Maybe (Handle prog)))
-> ReaderT Config IO (Maybe (Handle prog))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Nothing -> Maybe (Handle prog) -> ReaderT Config IO (Maybe (Handle prog))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Handle prog)
forall a. Maybe a
Nothing
    Just datalogExecutable :: FilePath
datalogExecutable -> do
      FilePath
souffleTempDir <- IO FilePath -> ReaderT Config IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ReaderT Config IO FilePath)
-> IO FilePath -> ReaderT Config IO FilePath
forall a b. (a -> b) -> a -> b
$ do
        FilePath
tmpDir <- IO FilePath
getCanonicalTemporaryDirectory
        FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmpDir "souffle-haskell"
      let factDir :: FilePath
factDir = FilePath
souffleTempDir FilePath -> ShowS
</> "fact"
          outDir :: FilePath
outDir  = FilePath
souffleTempDir FilePath -> ShowS
</> "out"
      IO () -> ReaderT Config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Config IO ()) -> IO () -> ReaderT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
factDir
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
outDir
      Maybe FilePath
mSouffleBin <- (Config -> Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> Maybe FilePath
cfgSouffleBin
      IO (Maybe (Handle prog)) -> ReaderT Config IO (Maybe (Handle prog))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Handle prog))
 -> ReaderT Config IO (Maybe (Handle prog)))
-> IO (Maybe (Handle prog))
-> ReaderT Config IO (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe FilePath
mSouffleBin ((FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog)))
-> (FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ \souffleBin :: FilePath
souffleBin ->
        (IORef HandleData -> Handle prog)
-> IO (IORef HandleData) -> IO (Handle prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef HandleData -> Handle prog
forall prog. IORef HandleData -> Handle prog
Handle (IO (IORef HandleData) -> IO (Handle prog))
-> IO (IORef HandleData) -> IO (Handle prog)
forall a b. (a -> b) -> a -> b
$ HandleData -> IO (IORef HandleData)
forall a. a -> IO (IORef a)
newIORef (HandleData -> IO (IORef HandleData))
-> HandleData -> IO (IORef HandleData)
forall a b. (a -> b) -> a -> b
$ HandleData :: FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Word64
-> HandleData
HandleData
          { soufflePath :: FilePath
soufflePath = FilePath
souffleBin
          , basePath :: FilePath
basePath    = FilePath
souffleTempDir
          , factPath :: FilePath
factPath    = FilePath
factDir
          , outputPath :: FilePath
outputPath  = FilePath
outDir
          , datalogExec :: FilePath
datalogExec = FilePath
datalogExecutable
          , noOfThreads :: Word64
noOfThreads = 1
          }
  {-# INLINABLE init #-}

  run :: Handler SouffleM prog -> SouffleM ()
run (Handle ref) = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
    -- Invoke the souffle binary using parameters, supposing that the facts
    -- are placed in the factPath, rendering the output into the outputPath.
    FilePath -> IO ()
callCommand (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> FilePath -> FilePath -> FilePath -> Word64 -> ShowS
forall r. PrintfType r => FilePath -> r
printf "%s -F%s -D%s -j%d %s"
        (HandleData -> FilePath
soufflePath HandleData
handle)
        (HandleData -> FilePath
factPath HandleData
handle)
        (HandleData -> FilePath
outputPath HandleData
handle)
        (HandleData -> Word64
noOfThreads HandleData
handle)
        (HandleData -> FilePath
datalogExec HandleData
handle)
  {-# INLINABLE run #-}

  setNumThreads :: Handler SouffleM prog -> Word64 -> SouffleM ()
setNumThreads (Handle ref) n :: Word64
n = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$
    IORef HandleData -> (HandleData -> HandleData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef HandleData
ref (\h :: HandleData
h -> HandleData
h { noOfThreads :: Word64
noOfThreads = Word64
n })
  {-# INLINABLE setNumThreads #-}

  getNumThreads :: Handler SouffleM prog -> SouffleM Word64
getNumThreads (Handle ref) = IO Word64 -> SouffleM Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word64 -> SouffleM Word64) -> IO Word64 -> SouffleM Word64
forall a b. (a -> b) -> a -> b
$
    HandleData -> Word64
noOfThreads (HandleData -> Word64) -> IO HandleData -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
  {-# INLINABLE getNumThreads #-}

  getFacts :: forall a c prog. (Marshal a, Fact a, ContainsFact prog a, Collect c)
           => Handle prog -> SouffleM (c a)
  getFacts :: Handle prog -> SouffleM (c a)
getFacts (Handle ref :: IORef HandleData
ref) = IO (c a) -> SouffleM (c a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (c a) -> SouffleM (c a)) -> IO (c a) -> SouffleM (c a)
forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
    let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: FilePath
factFile = HandleData -> FilePath
outputPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "csv"
    c a
facts <- FilePath -> IO (c a)
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
FilePath -> IO (c a)
collect FilePath
factFile
    c a -> IO (c a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c a -> IO (c a)) -> c a -> IO (c a)
forall a b. (a -> b) -> a -> b
$! c a
facts  -- force facts before running to avoid issues with lazy IO
  {-# INLINABLE getFacts #-}

  findFact :: (Fact a, ContainsFact prog a, Eq a)
           => Handle prog -> a -> SouffleM (Maybe a)
  findFact :: Handle prog -> a -> SouffleM (Maybe a)
findFact prog :: Handle prog
prog fact :: a
fact = do
    [a]
facts :: [a] <- Handler SouffleM prog -> SouffleM [a]
forall (m :: * -> *) a prog (c :: * -> *).
(MonadSouffle m, Fact a, ContainsFact prog a, CollectFacts m c) =>
Handler m prog -> m (c a)
getFacts Handler SouffleM prog
Handle prog
prog
    Maybe a -> SouffleM (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> SouffleM (Maybe a)) -> Maybe a -> SouffleM (Maybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
fact) [a]
facts
  {-# INLINABLE findFact #-}

  addFact :: forall a prog. (Fact a, ContainsFact prog a, Marshal a)
          => Handle prog -> a -> SouffleM ()
  addFact :: Handle prog -> a -> SouffleM ()
addFact (Handle ref :: IORef HandleData
ref) fact :: a
fact = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
    let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: FilePath
factFile = HandleData -> FilePath
factPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "facts"
    let line :: [FilePath]
line = MarshalM PushF () -> [FilePath]
forall a. MarshalM PushF a -> [FilePath]
pushMarshalT (a -> MarshalM PushF ()
forall a. Marshal a => a -> MarshalM PushF ()
push a
fact)
    FilePath -> FilePath -> IO ()
appendFile FilePath
factFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  {-# INLINABLE addFact #-}

  addFacts :: forall a prog f. (Fact a, ContainsFact prog a, Marshal a, Foldable f)
           => Handle prog -> f a -> SouffleM ()
  addFacts :: Handle prog -> f a -> SouffleM ()
addFacts (Handle ref :: IORef HandleData
ref) facts :: f a
facts = ReaderT Config IO () -> SouffleM ()
forall a. ReaderT Config IO a -> SouffleM a
SouffleM (ReaderT Config IO () -> SouffleM ())
-> ReaderT Config IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT Config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Config IO ()) -> IO () -> ReaderT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
    let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: FilePath
factFile = HandleData -> FilePath
factPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "facts"
    let factLines :: [[FilePath]]
factLines = (a -> [FilePath]) -> [a] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (MarshalM PushF () -> [FilePath]
forall a. MarshalM PushF a -> [FilePath]
pushMarshalT (MarshalM PushF () -> [FilePath])
-> (a -> MarshalM PushF ()) -> a -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MarshalM PushF ()
forall a. Marshal a => a -> MarshalM PushF ()
push) ((a -> [a]) -> f a -> [a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
facts)
    ([FilePath] -> IO ()) -> [[FilePath]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\line :: [FilePath]
line -> FilePath -> FilePath -> IO ()
appendFile FilePath
factFile (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")) [[FilePath]]
factLines
  {-# INLINABLE addFacts #-}

datalogProgramFile :: forall prog. Program prog => prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile :: prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile _ = do
  FilePath
dir <- (Config -> FilePath) -> ReaderT Config IO FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> FilePath
cfgDatalogDir
  let dlFile :: FilePath
dlFile = FilePath
dir FilePath -> ShowS
</> Proxy prog -> FilePath
forall a. Program a => Proxy a -> FilePath
programName (Proxy prog
forall k (t :: k). Proxy t
Proxy :: Proxy prog) FilePath -> ShowS
<.> "dl"
  IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath))
-> IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
dlFile IO Bool -> (Bool -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    False -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
    True -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dlFile
{-# INLINABLE datalogProgramFile #-}

locateSouffle :: IO (Maybe FilePath)
locateSouffle :: IO (Maybe FilePath)
locateSouffle = do
  let locateCmd :: CreateProcess
locateCmd = (FilePath -> CreateProcess
shell "which souffle") { std_out :: StdStream
std_out = StdStream
CreatePipe }
  (_, Just hout :: Handle
hout, _, locateCmdHandle :: ProcessHandle
locateCmdHandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
locateCmd
  ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
locateCmdHandle IO ExitCode
-> (ExitCode -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitFailure _ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
    ExitSuccess ->
      FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO FilePath
hGetContents Handle
hout IO [FilePath]
-> ([FilePath] -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [souffleBin :: FilePath
souffleBin] -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
souffleBin
        _ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
{-# INLINABLE locateSouffle #-}

readCSVFile :: FilePath -> IO [[String]]
readCSVFile :: FilePath -> IO [[FilePath]]
readCSVFile path :: FilePath
path = FilePath -> IO Bool
doesFileExist FilePath
path IO Bool -> (Bool -> IO [[FilePath]]) -> IO [[FilePath]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  False -> [[FilePath]] -> IO [[FilePath]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  True -> do
    FilePath
contents <- FilePath -> IO FilePath
readFile FilePath
path
    -- deepseq needed to avoid issues with lazy IO
    [[FilePath]] -> IO [[FilePath]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[FilePath]] -> IO [[FilePath]])
-> [[FilePath]] -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ FilePath
contents FilePath -> [[FilePath]] -> [[FilePath]]
forall a b. NFData a => a -> b -> b
`deepseq` ((FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> FilePath -> [FilePath]
splitOn '\t') ([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) FilePath
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 :: Handle prog -> SouffleM ()
cleanup (Handle ref :: IORef HandleData
ref) = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
  HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
  (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> IO ()
removeDirectoryRecursive [HandleData -> FilePath
factPath HandleData
handle, HandleData -> FilePath
outputPath HandleData
handle, HandleData -> FilePath
basePath HandleData
handle]
{-# INLINABLE cleanup #-}

splitOn :: Char -> String -> [String]
splitOn :: Char -> FilePath -> [FilePath]
splitOn c :: Char
c s :: FilePath
s =
  let (x :: FilePath
x, rest :: FilePath
rest) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) FilePath
s
      rest' :: FilePath
rest' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1 FilePath
rest
   in FilePath
x FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
splitOn Char
c FilePath
rest'
{-# INLINABLE splitOn #-}