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

-- | 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(..)
  , ProgramOptions(..)
  , Fact(..)
  , FactOptions(..)
  , 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 qualified Data.List as 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.Text.Short as TS
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 ((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
<$ :: forall a b. a -> SouffleM b -> SouffleM a
$c<$ :: forall a b. a -> SouffleM b -> SouffleM a
fmap :: forall a b. (a -> b) -> SouffleM a -> SouffleM b
$cfmap :: forall a b. (a -> b) -> SouffleM a -> SouffleM b
Functor, Functor SouffleM
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
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
<* :: forall a b. SouffleM a -> SouffleM b -> SouffleM a
$c<* :: forall a b. SouffleM a -> SouffleM b -> SouffleM a
*> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
$c*> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
liftA2 :: forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
<*> :: forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
$c<*> :: forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
pure :: forall a. a -> SouffleM a
$cpure :: forall a. a -> SouffleM a
Applicative, Applicative SouffleM
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
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 :: forall a. a -> SouffleM a
$creturn :: forall a. a -> SouffleM a
>> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
$c>> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
>>= :: forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
$c>>= :: forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
Monad, Monad SouffleM
Monad SouffleM
-> (forall a. IO a -> SouffleM a) -> MonadIO SouffleM
forall a. IO a -> SouffleM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> SouffleM a
$cliftIO :: forall a. IO a -> SouffleM a
MonadIO) via IO
  deriving (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 :: forall b. Integral b => 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
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 -> String
cfgDatalogDir   :: FilePath
  , Config -> Maybe String
cfgSouffleBin   :: Maybe FilePath
  , Config -> Maybe String
cfgFactDir      :: Maybe FilePath
  , Config -> Maybe String
cfgOutputDir    :: Maybe FilePath
  } deriving stock Int -> Config -> ShowS
[Config] -> ShowS
Config -> String
(Int -> Config -> ShowS)
-> (Config -> String) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> String
$cshow :: Config -> String
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 :: forall (m :: * -> *). MonadIO m => 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 String
dlDir <- String -> IO (Maybe String)
lookupEnv String
"DATALOG_DIR"
  Maybe (Last String)
envSouffleBin <- (String -> Last String) -> Maybe String -> Maybe (Last String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Last String
forall a. a -> Last a
Last (Maybe String -> Maybe (Last String))
-> IO (Maybe String) -> IO (Maybe (Last String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"SOUFFLE_BIN"
  Maybe (Last String)
locatedBin <- (String -> Last String) -> Maybe String -> Maybe (Last String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Last String
forall a. a -> Last a
Last (Maybe String -> Maybe (Last String))
-> IO (Maybe String) -> IO (Maybe (Last String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String)
locateSouffle
  let souffleBin :: Maybe String
souffleBin = Last String -> String
forall a. Last a -> a
getLast (Last String -> String) -> Maybe (Last String) -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Last String)
locatedBin Maybe (Last String) -> Maybe (Last String) -> Maybe (Last String)
forall a. Semigroup a => a -> a -> a
<> Maybe (Last String)
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
$ String -> Maybe String -> Maybe String -> Maybe String -> Config
Config (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"." Maybe String
dlDir) Maybe String
souffleBin Maybe String
forall a. Maybe a
Nothing Maybe String
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 :: forall prog a.
Program prog =>
prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffle prog
program 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 :: forall prog a.
Program prog =>
Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffleWith Config
cfg prog
program 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
$ \Maybe (Handle prog)
handle -> do
  let (SouffleM IO a
action) = Maybe (Handle prog) -> SouffleM a
f Maybe (Handle prog)
handle
  IO a
action
  where
    initialize :: IO (Maybe (Handle prog))
initialize = prog -> String -> IO (Maybe String)
forall prog. Program prog => prog -> String -> IO (Maybe String)
datalogProgramFile prog
program (Config -> String
cfgDatalogDir Config
cfg) IO (Maybe String)
-> (Maybe String -> IO (Maybe (Handle prog)))
-> IO (Maybe (Handle prog))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe String
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 String
datalogExecutable -> do
        String
tmpDir <- IO String
getCanonicalTemporaryDirectory
        String
souffleTempDir <- String -> String -> IO String
createTempDirectory String
tmpDir String
"souffle-haskell"
        let factDir :: String
factDir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
souffleTempDir String -> ShowS
</> String
"fact") (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
cfgFactDir Config
cfg
            outDir :: String
outDir = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String
souffleTempDir String -> ShowS
</> String
"out") (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
cfgOutputDir Config
cfg
        (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool -> String -> IO ()
createDirectoryIfMissing Bool
True) [String
factDir, String
outDir]
        Maybe String
-> (String -> 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 String
mSouffleBin ((String -> IO (Handle prog)) -> IO (Maybe (Handle prog)))
-> (String -> IO (Handle prog)) -> IO (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ \String
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 :: String
-> String -> String -> String -> String -> Word64 -> HandleData
HandleData
                  { soufflePath :: String
soufflePath = String
souffleBin
                  , tmpDirPath :: String
tmpDirPath  = String
souffleTempDir
                  , factPath :: String
factPath    = String
factDir
                  , outputPath :: String
outputPath  = String
outDir
                  , datalogExec :: String
datalogExec = String
datalogExecutable
                  , noOfThreads :: Word64
noOfThreads = Word64
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
$ \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
      String -> IO ()
removeDirectoryRecursive (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ HandleData -> String
tmpDirPath HandleData
handle
    mSouffleBin :: Maybe String
mSouffleBin = Config -> Maybe String
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
  { forall prog. Handle prog -> IORef HandleData
handleData   :: IORef HandleData
  , forall prog. Handle prog -> IORef (Maybe Text)
stdoutResult :: IORef (Maybe T.Text)
  , forall prog. Handle prog -> IORef (Maybe Text)
stderrResult :: IORef (Maybe T.Text)
  }
type role Handle nominal

-- | 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 -> String
soufflePath :: FilePath
  , HandleData -> String
tmpDirPath  :: FilePath
  , HandleData -> String
factPath    :: FilePath
  , HandleData -> String
outputPath  :: FilePath
  , HandleData -> String
datalogExec :: FilePath
  , HandleData -> Word64
noOfThreads :: Word64
  }

newtype IMarshal a = IMarshal (State [String] a)
  deriving ((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
<$ :: forall a b. a -> IMarshal b -> IMarshal a
$c<$ :: forall a b. a -> IMarshal b -> IMarshal a
fmap :: forall a b. (a -> b) -> IMarshal a -> IMarshal b
$cfmap :: forall a b. (a -> b) -> IMarshal a -> IMarshal b
Functor, Functor IMarshal
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
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
<* :: forall a b. IMarshal a -> IMarshal b -> IMarshal a
$c<* :: forall a b. IMarshal a -> IMarshal b -> IMarshal a
*> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
$c*> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
liftA2 :: forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
<*> :: forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
$c<*> :: forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
pure :: forall a. a -> IMarshal a
$cpure :: forall a. a -> IMarshal a
Applicative, Applicative IMarshal
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
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 :: forall a. a -> IMarshal a
$creturn :: forall a. a -> IMarshal a
>> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
$c>> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
>>= :: forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
$c>>= :: forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
Monad, MonadState [String])
  via (State [String])

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

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

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

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

  pushText :: ShortText -> IMarshal ()
pushText ShortText
txt = String -> IMarshal ()
forall (m :: * -> *). MonadPush m => String -> m ()
pushString (ShortText -> String
TS.unpack ShortText
txt)
  {-# INLINABLE pushText #-}

  pushTextUtf16 :: Text -> IMarshal ()
pushTextUtf16 Text
txt = String -> IMarshal ()
forall (m :: * -> *). MonadPush m => String -> m ()
pushString (Text -> String
T.unpack Text
txt)
  {-# INLINABLE pushTextUtf16 #-}

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

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

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

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

  popText :: IMarshal ShortText
popText = do
    String
str <- ([String] -> (String, [String])) -> IMarshal String
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([String] -> (String, [String])) -> IMarshal String)
-> ([String] -> (String, [String])) -> IMarshal String
forall a b. (a -> b) -> a -> b
$ \case
      [] -> String -> (String, [String])
forall a. HasCallStack => String -> a
error String
"Empty fact stack"
      (String
h:[String]
t) -> (String
h, [String]
t)
    ShortText -> IMarshal ShortText
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShortText -> IMarshal ShortText)
-> ShortText -> IMarshal ShortText
forall a b. (a -> b) -> a -> b
$ String -> ShortText
TS.pack String
str
  {-# INLINABLE popText #-}

  popTextUtf16 :: IMarshal Text
popTextUtf16 = do
    String
str <- ([String] -> (String, [String])) -> IMarshal String
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (([String] -> (String, [String])) -> IMarshal String)
-> ([String] -> (String, [String])) -> IMarshal String
forall a b. (a -> b) -> a -> b
$ \case
      [] -> String -> (String, [String])
forall a. HasCallStack => String -> a
error String
"Empty fact stack"
      (String
h:[String]
t) -> (String
h, [String]
t)
    Text -> IMarshal Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IMarshal Text) -> Text -> IMarshal Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
str
  {-# INLINABLE popTextUtf16 #-}

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

pushMarshalT :: IMarshal a -> [String]
pushMarshalT :: forall a. IMarshal a -> [String]
pushMarshalT (IMarshal State [String] a
m) = [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ State [String] a -> [String] -> [String]
forall s a. State s a -> s -> s
execState State [String] a
m []
{-# INLINABLE pushMarshalT #-}

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

instance Collect [] where
  collect :: forall a. Marshal a => String -> IO [a]
collect String
factFile = do
    [[String]]
factLines <- String -> IO [[String]]
readCSVFile String
factFile
    let facts :: [a]
facts = ([String] -> a) -> [[String]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (IMarshal a -> [String] -> a
forall a. IMarshal a -> [String] -> a
popMarshalT IMarshal a
forall a (m :: * -> *). (Marshal a, MonadPop m) => m a
pop) [[String]]
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 :: forall a. Marshal a => String -> IO (Vector a)
collect String
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
<$!> String -> IO [a]
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
String -> IO (c a)
collect String
factFile
  {-# INLINABLE collect #-}

instance Collect (A.Array Int) where
  collect :: forall a. Marshal a => String -> IO (Array Int a)
collect String
factFile = do
    [a]
facts <- String -> IO [a]
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
String -> IO (c a)
collect String
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 (Int
0, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
facts
  {-# INLINABLE collect #-}

instance MonadSouffle SouffleM where
  type Handler SouffleM = Handle
  type CollectFacts SouffleM c = Collect c
  type SubmitFacts SouffleM _ = ()

  run :: forall prog. Handler SouffleM prog -> SouffleM ()
run (Handle IORef HandleData
refHandleData IORef (Maybe Text)
refHandleStdOut IORef (Maybe Text)
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 =
          (String -> CreateProcess
shell
            (String -> String -> String -> String -> Word64 -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s -F%s -D%s -j%d %s"
              (HandleData -> String
soufflePath HandleData
handle)
              (HandleData -> String
factPath HandleData
handle)
              (HandleData -> String
outputPath HandleData
handle)
              (HandleData -> Word64
noOfThreads HandleData
handle)
              (HandleData -> String
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
      (String
-> CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess_ String
"souffle-haskell" CreateProcess
processToRun)
      (\(Maybe Handle
_, Maybe Handle
mStdOutHandle, Maybe Handle
mStdErrHandle, ProcessHandle
_) -> 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
      )
      (\(Maybe Handle
_, Maybe Handle
mStdOutHandle, Maybe Handle
mStdErrHandle, 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
          ExitCode
ExitSuccess   -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ExitFailure Int
c -> ErrorCall -> IO ()
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ()) -> ErrorCall -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall (String -> ErrorCall) -> String -> ErrorCall
forall a b. (a -> b) -> a -> b
$ String
"Souffle exited with: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
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
$ \Handle
stdoutHandle -> do
          Text
stdout <- String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO String
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
$ \Handle
stderrHandle -> do
          Text
stderr <- String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO String
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 :: forall prog. Handler SouffleM prog -> Word64 -> SouffleM ()
setNumThreads Handler SouffleM prog
handle 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) (\HandleData
h -> HandleData
h { noOfThreads :: Word64
noOfThreads = Word64
n })
  {-# INLINABLE setNumThreads #-}

  getNumThreads :: forall prog. Handler SouffleM prog -> SouffleM Word64
getNumThreads 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 :: forall a (c :: * -> *) prog.
(Marshal a, Fact a, ContainsOutputFact prog a, Collect c) =>
Handle prog -> SouffleM (c a)
getFacts 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 :: String
relationName = Proxy a -> String
forall a. Fact a => Proxy a -> String
factName (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: String
factFile = HandleData -> String
outputPath HandleData
handle String -> ShowS
</> String
relationName String -> ShowS
<.> String
"csv"
    c a
facts <- String -> IO (c a)
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
String -> IO (c a)
collect String
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 :: forall a prog.
(Fact a, ContainsOutputFact prog a, Eq a) =>
Handle prog -> a -> SouffleM (Maybe a)
findFact Handle prog
prog 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
List.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 :: forall a prog.
(Fact a, ContainsInputFact prog a, Marshal a) =>
Handle prog -> a -> SouffleM ()
addFact Handle prog
h 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 :: String
relationName = Proxy a -> String
forall a. Fact a => Proxy a -> String
factName (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: String
factFile = HandleData -> String
factPath HandleData
handle String -> ShowS
</> String
relationName String -> ShowS
<.> String
"facts"
    let line :: [String]
line = IMarshal () -> [String]
forall a. IMarshal a -> [String]
pushMarshalT (a -> IMarshal ()
forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push a
fact)
    String -> String -> IO ()
appendFile String
factFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\t" [String]
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
  {-# INLINABLE addFact #-}

  addFacts :: forall a prog f. (Fact a, ContainsInputFact prog a, Marshal a, Foldable f)
           => Handle prog -> f a -> SouffleM ()
  addFacts :: forall a prog (f :: * -> *).
(Fact a, ContainsInputFact prog a, Marshal a, Foldable f) =>
Handle prog -> f a -> SouffleM ()
addFacts Handle prog
h 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 :: String
relationName = Proxy a -> String
forall a. Fact a => Proxy a -> String
factName (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    let factFile :: String
factFile = HandleData -> String
factPath HandleData
handle String -> ShowS
</> String
relationName String -> ShowS
<.> String
"facts"
    let factLines :: [[String]]
factLines = (a -> [String]) -> [a] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (IMarshal () -> [String]
forall a. IMarshal a -> [String]
pushMarshalT (IMarshal () -> [String]) -> (a -> IMarshal ()) -> a -> [String]
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)
    ([String] -> IO ()) -> [[String]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\[String]
line -> String -> String -> IO ()
appendFile String
factFile (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\t" [String]
line String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n")) [[String]]
factLines
  {-# INLINABLE addFacts #-}

datalogProgramFile :: forall prog. Program prog => prog -> FilePath -> IO (Maybe FilePath)
datalogProgramFile :: forall prog. Program prog => prog -> String -> IO (Maybe String)
datalogProgramFile prog
prog String
datalogDir = do
  let dlFile :: String
dlFile = String
datalogDir String -> ShowS
</> prog -> String
forall a. Program a => a -> String
programName prog
prog String -> ShowS
<.> String
"dl"
  String -> IO Bool
doesFileExist String
dlFile IO Bool -> (Bool -> IO (Maybe String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    Bool
True -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
dlFile
{-# INLINABLE datalogProgramFile #-}

locateSouffle :: IO (Maybe FilePath)
locateSouffle :: IO (Maybe String)
locateSouffle = do
  let locateCmd :: CreateProcess
locateCmd = (String -> CreateProcess
shell String
"which souffle") { std_out :: StdStream
std_out = StdStream
CreatePipe }
  (Maybe Handle
_, Just Handle
hout, Maybe Handle
_, 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 String)) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitFailure Int
_ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
    ExitCode
ExitSuccess -> do
      String
contents <- Handle -> IO String
hGetContents Handle
hout
      case String -> [String]
words String
contents of
        [String
souffleBin] -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
souffleBin
        [String]
_ -> Maybe String -> IO (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing
{-# INLINABLE locateSouffle #-}

readCSVFile :: FilePath -> IO [[String]]
readCSVFile :: String -> IO [[String]]
readCSVFile String
path = String -> IO Bool
doesFileExist String
path IO Bool -> (Bool -> IO [[String]]) -> IO [[String]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> [[String]] -> IO [[String]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  Bool
True -> do
    String
contents <- String -> IO String
readFile String
path
    -- deepseq needed to avoid issues with lazy IO
    [[String]] -> IO [[String]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[String]] -> IO [[String]]) -> [[String]] -> IO [[String]]
forall a b. (a -> b) -> a -> b
$ String
contents String -> [[String]] -> [[String]]
forall a b. NFData a => a -> b -> b
`deepseq` ((String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> [String]
splitOn Char
'\t') ([String] -> [[String]])
-> (String -> [String]) -> String -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines) String
contents
{-# INLINABLE readCSVFile #-}

-- | Returns the handle of stdout from the souffle interpreter.
souffleStdOut :: forall prog. Program prog => Handle prog -> SouffleM (Maybe T.Text)
souffleStdOut :: forall prog. Program prog => 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 :: forall prog. Program prog => 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 -> String -> [String]
splitOn Char
c String
s =
  let (String
x, String
rest) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) String
s
      rest' :: String
rest' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
rest
   in String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Char -> String -> [String]
splitOn Char
c String
rest'
{-# INLINABLE splitOn #-}