{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, TypeFamilies, DerivingVia, InstanceSigs, UndecidableInstances #-}

-- | 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(..)
  , Direction(..)
  , ContainsInputFact
  , ContainsOutputFact
  , Config(..)
  , Handle
  , SouffleM
  , MonadSouffle(..)
  , runSouffle
  , runSouffleWith
  , defaultConfig
  , souffleStdOut
  , souffleStdErr
  ) where

import Prelude hiding (init)

import Control.DeepSeq (deepseq)
import Control.Exception (ErrorCall(..), throwIO, bracket)
import Control.Monad.State.Strict
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.Array as A
import qualified Data.Text as T
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, hClose)
import System.IO.Temp
import System.Process
import Text.Printf


-- | A monad for executing Souffle-related actions in.
newtype SouffleM a = SouffleM (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 IO
  deriving (b -> SouffleM a -> SouffleM a
NonEmpty (SouffleM a) -> SouffleM a
SouffleM a -> SouffleM a -> SouffleM a
(SouffleM a -> SouffleM a -> SouffleM a)
-> (NonEmpty (SouffleM a) -> SouffleM a)
-> (forall b. Integral b => b -> SouffleM a -> SouffleM a)
-> Semigroup (SouffleM a)
forall b. Integral b => b -> SouffleM a -> SouffleM a
forall a. Semigroup a => NonEmpty (SouffleM a) -> SouffleM a
forall a. Semigroup a => SouffleM a -> SouffleM a -> SouffleM a
forall a b.
(Semigroup a, Integral b) =>
b -> SouffleM a -> SouffleM a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> SouffleM a -> SouffleM a
$cstimes :: forall a b.
(Semigroup a, Integral b) =>
b -> SouffleM a -> SouffleM a
sconcat :: NonEmpty (SouffleM a) -> SouffleM a
$csconcat :: forall a. Semigroup a => NonEmpty (SouffleM a) -> SouffleM a
<> :: SouffleM a -> SouffleM a -> SouffleM a
$c<> :: forall a. Semigroup a => SouffleM a -> SouffleM a -> SouffleM a
Semigroup, Semigroup (SouffleM a)
SouffleM a
Semigroup (SouffleM a) =>
SouffleM a
-> (SouffleM a -> SouffleM a -> SouffleM a)
-> ([SouffleM a] -> SouffleM a)
-> Monoid (SouffleM a)
[SouffleM a] -> SouffleM a
SouffleM a -> SouffleM a -> SouffleM a
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall a. Monoid a => Semigroup (SouffleM a)
forall a. Monoid a => SouffleM a
forall a. Monoid a => [SouffleM a] -> SouffleM a
forall a. Monoid a => SouffleM a -> SouffleM a -> SouffleM a
mconcat :: [SouffleM a] -> SouffleM a
$cmconcat :: forall a. Monoid a => [SouffleM a] -> SouffleM a
mappend :: SouffleM a -> SouffleM a -> SouffleM a
$cmappend :: forall a. Monoid a => SouffleM a -> SouffleM a -> SouffleM a
mempty :: SouffleM a
$cmempty :: forall a. Monoid a => SouffleM a
$cp1Monoid :: forall a. Monoid a => Semigroup (SouffleM a)
Monoid) via (IO a)

-- | 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.
--   - __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 fact file(s) are created.
--   If Nothing, it will be part of the temporary directory.
data Config
  = Config
  { Config -> FilePath
cfgDatalogDir   :: FilePath
  , Config -> Maybe FilePath
cfgSouffleBin   :: Maybe FilePath
  , Config -> Maybe FilePath
cfgFactDir      :: Maybe FilePath
  , Config -> Maybe FilePath
cfgOutputDir    :: 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.
--   - __cfgFactDir__: Will make use of a temporary directory.
--   - __cfgOutputDir__: Will make use of a temporary directory.
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 -> Maybe FilePath -> Maybe FilePath -> Config
Config (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "." Maybe FilePath
dlDir) Maybe FilePath
souffleBin Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
{-# INLINABLE defaultConfig #-}

{- | 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 :: prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffle program :: prog
program m :: Maybe (Handle prog) -> SouffleM a
m = do
  Config
cfg <- IO Config
forall (m :: * -> *). MonadIO m => m Config
defaultConfig
  Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
forall prog a.
Program prog =>
Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffleWith Config
cfg prog
program Maybe (Handle prog) -> SouffleM a
m
{-# INLINABLE runSouffle #-}

{- | 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 :: Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffleWith cfg :: Config
cfg program :: prog
program f :: Maybe (Handle prog) -> SouffleM a
f = IO (Maybe (Handle prog))
-> (Maybe (Handle prog) -> IO ())
-> (Maybe (Handle prog) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe (Handle prog))
initialize Maybe (Handle prog) -> IO ()
forall prog. Maybe (Handle prog) -> IO ()
maybeCleanup ((Maybe (Handle prog) -> IO a) -> IO a)
-> (Maybe (Handle prog) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \handle :: Maybe (Handle prog)
handle -> do
  let (SouffleM action :: IO a
action) = Maybe (Handle prog) -> SouffleM a
f Maybe (Handle prog)
handle
  IO a
action
  where
    initialize :: IO (Maybe (Handle prog))
initialize = prog -> FilePath -> IO (Maybe FilePath)
forall prog.
Program prog =>
prog -> FilePath -> IO (Maybe FilePath)
datalogProgramFile prog
program (Config -> FilePath
cfgDatalogDir Config
cfg) IO (Maybe FilePath)
-> (Maybe FilePath -> IO (Maybe (Handle prog)))
-> IO (Maybe (Handle prog))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Nothing -> Maybe (Handle prog) -> 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
tmpDir <- IO FilePath
getCanonicalTemporaryDirectory
        FilePath
souffleTempDir <- FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmpDir "souffle-haskell"
        let factDir :: FilePath
factDir = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath
souffleTempDir FilePath -> ShowS
</> "fact") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Config -> Maybe FilePath
cfgFactDir Config
cfg
            outDir :: FilePath
outDir = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath
souffleTempDir FilePath -> ShowS
</> "out") (Maybe FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Config -> Maybe FilePath
cfgOutputDir Config
cfg
        (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True) [FilePath
factDir, FilePath
outDir]
        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
-> IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog
forall prog.
IORef HandleData
-> IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog
Handle
            (IORef HandleData
 -> IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog)
-> IO (IORef HandleData)
-> IO (IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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
                  , tmpDirPath :: FilePath
tmpDirPath  = FilePath
souffleTempDir
                  , factPath :: FilePath
factPath    = FilePath
factDir
                  , outputPath :: FilePath
outputPath  = FilePath
outDir
                  , datalogExec :: FilePath
datalogExec = FilePath
datalogExecutable
                  , noOfThreads :: Word64
noOfThreads = 1
                  })
            IO (IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog)
-> IO (IORef (Maybe Text))
-> IO (IORef (Maybe Text) -> Handle prog)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
            IO (IORef (Maybe Text) -> Handle prog)
-> IO (IORef (Maybe Text)) -> IO (Handle prog)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Text -> IO (IORef (Maybe Text))
forall a. a -> IO (IORef a)
newIORef Maybe Text
forall a. Maybe a
Nothing
    maybeCleanup :: Maybe (Handle prog) -> IO ()
maybeCleanup = IO () -> (Handle prog -> IO ()) -> Maybe (Handle prog) -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ()
forall a. Monoid a => a
mempty ((Handle prog -> IO ()) -> Maybe (Handle prog) -> IO ())
-> (Handle prog -> IO ()) -> Maybe (Handle prog) -> IO ()
forall a b. (a -> b) -> a -> b
$ \h :: Handle prog
h -> do
      HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef (IORef HandleData -> IO HandleData)
-> IORef HandleData -> IO HandleData
forall a b. (a -> b) -> a -> b
$ Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
      FilePath -> IO ()
removeDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ HandleData -> FilePath
tmpDirPath HandleData
handle
    mSouffleBin :: Maybe FilePath
mSouffleBin = Config -> Maybe FilePath
cfgSouffleBin 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.
data Handle prog = Handle
  { Handle prog -> IORef HandleData
handleData   :: IORef HandleData
  , Handle prog -> IORef (Maybe Text)
stdoutResult :: IORef (Maybe T.Text)
  , Handle prog -> IORef (Maybe Text)
stderrResult :: IORef (Maybe T.Text)
  }

-- | 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
tmpDirPath  :: 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])

instance MonadPush IMarshal where
  pushInt32 :: Int32 -> IMarshal ()
pushInt32 int :: Int32
int = ([FilePath] -> [FilePath]) -> IMarshal ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int32 -> FilePath
forall a. Show a => a -> FilePath
show Int32
intFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
  {-# INLINABLE pushInt32 #-}

  pushUInt32 :: Word32 -> IMarshal ()
pushUInt32 int :: Word32
int = ([FilePath] -> [FilePath]) -> IMarshal ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Word32 -> FilePath
forall a. Show a => a -> FilePath
show Word32
intFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
  {-# INLINABLE pushUInt32 #-}

  pushFloat :: Float -> IMarshal ()
pushFloat float :: Float
float = ([FilePath] -> [FilePath]) -> IMarshal ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Float -> FilePath
forall a. Show a => a -> FilePath
show Float
floatFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
  {-# INLINABLE pushFloat #-}

  pushString :: FilePath -> IMarshal ()
pushString str :: FilePath
str = ([FilePath] -> [FilePath]) -> IMarshal ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath
strFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
  {-# INLINABLE pushString #-}

instance MonadPop IMarshal where
  popInt32 :: IMarshal Int32
popInt32 = ([FilePath] -> (Int32, [FilePath])) -> IMarshal Int32
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([FilePath] -> (Int32, [FilePath])) -> IMarshal Int32)
-> ([FilePath] -> (Int32, [FilePath])) -> IMarshal Int32
forall a b. (a -> b) -> a -> b
$ \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)
  {-# INLINABLE popInt32 #-}

  popUInt32 :: IMarshal Word32
popUInt32 = ([FilePath] -> (Word32, [FilePath])) -> IMarshal Word32
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([FilePath] -> (Word32, [FilePath])) -> IMarshal Word32)
-> ([FilePath] -> (Word32, [FilePath])) -> IMarshal Word32
forall a b. (a -> b) -> a -> b
$ \case
    [] -> FilePath -> (Word32, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
    (h :: FilePath
h:t :: [FilePath]
t) -> (FilePath -> Word32
forall a. Read a => FilePath -> a
read FilePath
h, [FilePath]
t)
  {-# INLINABLE popUInt32 #-}

  popFloat :: IMarshal Float
popFloat = ([FilePath] -> (Float, [FilePath])) -> IMarshal Float
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([FilePath] -> (Float, [FilePath])) -> IMarshal Float)
-> ([FilePath] -> (Float, [FilePath])) -> IMarshal Float
forall a b. (a -> b) -> a -> b
$ \case
    [] -> FilePath -> (Float, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
    (h :: FilePath
h:t :: [FilePath]
t) -> (FilePath -> Float
forall a. Read a => FilePath -> a
read FilePath
h, [FilePath]
t)
  {-# INLINABLE popFloat #-}

  popString :: IMarshal FilePath
popString = ([FilePath] -> (FilePath, [FilePath])) -> IMarshal FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([FilePath] -> (FilePath, [FilePath])) -> IMarshal FilePath)
-> ([FilePath] -> (FilePath, [FilePath])) -> IMarshal FilePath
forall a b. (a -> b) -> a -> b
$ \case
    [] -> FilePath -> (FilePath, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
    (h :: FilePath
h:t :: [FilePath]
t) -> (FilePath
h, [FilePath]
t)
  {-# INLINABLE popString #-}

popMarshalT :: IMarshal a -> [String] -> a
popMarshalT :: IMarshal a -> [FilePath] -> a
popMarshalT (IMarshal m :: State [FilePath] a
m) = State [FilePath] a -> [FilePath] -> a
forall s a. State s a -> s -> a
evalState State [FilePath] a
m
{-# INLINABLE popMarshalT #-}

pushMarshalT :: IMarshal a -> [String]
pushMarshalT :: IMarshal a -> [FilePath]
pushMarshalT (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 []
{-# 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 (IMarshal a -> [FilePath] -> a
forall a. IMarshal a -> [FilePath] -> a
popMarshalT IMarshal a
forall a (m :: * -> *). (Marshal a, MonadPop m) => m 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 Collect (A.Array Int) where
  collect :: FilePath -> IO (Array Int a)
collect factFile :: FilePath
factFile = do
    [a]
facts <- FilePath -> IO [a]
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
FilePath -> IO (c a)
collect FilePath
factFile
    let count :: Int
count = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
facts
    Array Int a -> IO (Array Int a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Array Int a -> IO (Array Int a))
-> Array Int a -> IO (Array Int a)
forall a b. (a -> b) -> a -> b
$! (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (0, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) [a]
facts
  {-# INLINABLE collect #-}

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

  run :: Handler SouffleM prog -> SouffleM ()
run (Handle refHandleData refHandleStdOut refHandleStdErr) = 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
refHandleData
    -- Invoke the souffle binary using parameters, supposing that the facts
    -- are placed in the factPath, rendering the output into the outputPath.
    let processToRun :: CreateProcess
processToRun =
          (FilePath -> CreateProcess
shell
            (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)))
            { std_in :: StdStream
std_in  = StdStream
NoStream
            , std_out :: StdStream
std_out = StdStream
CreatePipe
            , std_err :: StdStream
std_err = StdStream
CreatePipe
            }
    IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
      (FilePath
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ "souffle-haskell" CreateProcess
processToRun)
      (\(_, mStdOutHandle :: Maybe Handle
mStdOutHandle, mStdErrHandle :: Maybe Handle
mStdErrHandle, _) -> do
        (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose Maybe Handle
mStdOutHandle
        (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose Maybe Handle
mStdErrHandle
      )
      (\(_, mStdOutHandle :: Maybe Handle
mStdOutHandle, mStdErrHandle :: Maybe Handle
mStdErrHandle, processHandle :: ProcessHandle
processHandle) -> do
        ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle IO ExitCode -> (ExitCode -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          ExitSuccess   -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ExitFailure c :: Int
c -> ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ()) -> ErrorCall -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ "Souffle exited with: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
c
        Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
mStdOutHandle ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \stdoutHandle :: Handle
stdoutHandle -> do
          Text
stdout <- FilePath -> Text
T.pack (FilePath -> Text) -> IO FilePath -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO FilePath
hGetContents Handle
stdoutHandle
          IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
refHandleStdOut (Maybe Text -> IO ()) -> Maybe Text -> IO ()
forall a b. (a -> b) -> a -> b
$! Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$! Text
stdout
        Maybe Handle -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
mStdErrHandle ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \stderrHandle :: Handle
stderrHandle -> do
          Text
stderr <- FilePath -> Text
T.pack (FilePath -> Text) -> IO FilePath -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO FilePath
hGetContents Handle
stderrHandle
          IORef (Maybe Text) -> Maybe Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
refHandleStdErr (Maybe Text -> IO ()) -> Maybe Text -> IO ()
forall a b. (a -> b) -> a -> b
$! Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$! Text
stderr
      )
  {-# INLINABLE run #-}

  setNumThreads :: Handler SouffleM prog -> Word64 -> SouffleM ()
setNumThreads handle :: Handler SouffleM prog
handle 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' (Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handler SouffleM prog
Handle prog
handle) (\h :: HandleData
h -> HandleData
h { noOfThreads :: Word64
noOfThreads = Word64
n })
  {-# INLINABLE setNumThreads #-}

  getNumThreads :: Handler SouffleM prog -> SouffleM Word64
getNumThreads handle :: Handler SouffleM prog
handle = 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 (Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handler SouffleM prog
Handle prog
handle)
  {-# INLINABLE getNumThreads #-}

  getFacts :: forall a c prog. (Marshal a, Fact a, ContainsOutputFact prog a, Collect c)
           => Handle prog -> SouffleM (c a)
  getFacts :: Handle prog -> SouffleM (c a)
getFacts h :: Handle prog
h = 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 -> IO HandleData)
-> IORef HandleData -> IO HandleData
forall a b. (a -> b) -> a -> b
$ Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    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, ContainsOutputFact 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, ContainsOutputFact 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, ContainsInputFact prog a, Marshal a)
          => Handle prog -> a -> SouffleM ()
  addFact :: Handle prog -> a -> SouffleM ()
addFact h :: Handle prog
h 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 -> IO HandleData)
-> IORef HandleData -> IO HandleData
forall a b. (a -> b) -> a -> b
$ Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    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 = IMarshal () -> [FilePath]
forall a. IMarshal a -> [FilePath]
pushMarshalT (a -> IMarshal ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
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, ContainsInputFact prog a, Marshal a, Foldable f)
           => Handle prog -> f a -> SouffleM ()
  addFacts :: Handle prog -> f a -> SouffleM ()
addFacts h :: Handle prog
h facts :: f a
facts = 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 -> IO HandleData)
-> IORef HandleData -> IO HandleData
forall a b. (a -> b) -> a -> b
$ Handle prog -> IORef HandleData
forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    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 (IMarshal () -> [FilePath]
forall a. IMarshal a -> [FilePath]
pushMarshalT (IMarshal () -> [FilePath])
-> (a -> IMarshal ()) -> a -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> IMarshal ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
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 -> FilePath -> IO (Maybe FilePath)
datalogProgramFile :: prog -> FilePath -> IO (Maybe FilePath)
datalogProgramFile prog :: prog
prog datalogDir :: FilePath
datalogDir = do
  let dlFile :: FilePath
dlFile = FilePath
datalogDir FilePath -> ShowS
</> prog -> FilePath
forall a. Program a => a -> FilePath
programName prog
prog FilePath -> ShowS
<.> "dl"
  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 #-}

-- | Returns the handle of stdout from the souffle interpreter.
souffleStdOut :: forall prog. Program prog => Handle prog -> SouffleM (Maybe T.Text)
souffleStdOut :: Handle prog -> SouffleM (Maybe Text)
souffleStdOut = IO (Maybe Text) -> SouffleM (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> SouffleM (Maybe Text))
-> (Handle prog -> IO (Maybe Text))
-> Handle prog
-> SouffleM (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef (IORef (Maybe Text) -> IO (Maybe Text))
-> (Handle prog -> IORef (Maybe Text))
-> Handle prog
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle prog -> IORef (Maybe Text)
forall prog. Handle prog -> IORef (Maybe Text)
stdoutResult

-- | Returns the content of stderr from the souffle interpreter.
souffleStdErr :: forall prog. Program prog => Handle prog -> SouffleM (Maybe T.Text)
souffleStdErr :: Handle prog -> SouffleM (Maybe Text)
souffleStdErr = IO (Maybe Text) -> SouffleM (Maybe Text)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Text) -> SouffleM (Maybe Text))
-> (Handle prog -> IO (Maybe Text))
-> Handle prog
-> SouffleM (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (Maybe Text) -> IO (Maybe Text)
forall a. IORef a -> IO a
readIORef (IORef (Maybe Text) -> IO (Maybe Text))
-> (Handle prog -> IORef (Maybe Text))
-> Handle prog
-> IO (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle prog -> IORef (Maybe Text)
forall prog. Handle prog -> IORef (Maybe Text)
stderrResult

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 #-}