{-# 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 Data.Kind (Type, Constraint)

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.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.
type SouffleM :: Type -> Type
newtype SouffleM a = SouffleM (IO a)
  deriving (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
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
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
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
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, 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.
type Config :: Type
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
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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Maybe String
dlDir <- String -> IO (Maybe String)
lookupEnv String
"DATALOG_DIR"
  Maybe (Last String)
envSouffleBin <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Last a
Last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"SOUFFLE_BIN"
  Maybe (Last String)
locatedBin <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Last a
Last forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe String)
locateSouffle
  let souffleBin :: Maybe String
souffleBin = forall a. Last a -> a
getLast forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Last String)
locatedBin forall a. Semigroup a => a -> a -> a
<> Maybe (Last String)
envSouffleBin
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> Maybe String -> Maybe String -> Config
Config (forall a. a -> Maybe a -> a
fromMaybe String
"." Maybe String
dlDir) Maybe String
souffleBin forall a. Maybe a
Nothing 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 <- forall (m :: * -> *). MonadIO m => m Config
defaultConfig
  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 = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe (Handle prog))
initialize forall {prog}. Maybe (Handle prog) -> IO ()
maybeCleanup 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 = forall prog. Program prog => prog -> String -> IO (Maybe String)
datalogProgramFile prog
program (Config -> String
cfgDatalogDir Config
cfg) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. a -> Maybe a -> a
fromMaybe (String
souffleTempDir String -> ShowS
</> String
"fact") forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
cfgFactDir Config
cfg
            outDir :: String
outDir = forall a. a -> Maybe a -> a
fromMaybe (String
souffleTempDir String -> ShowS
</> String
"out") forall a b. (a -> b) -> a -> b
$ Config -> Maybe String
cfgOutputDir Config
cfg
        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]
        forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe String
mSouffleBin forall a b. (a -> b) -> a -> b
$ \String
souffleBin ->
          forall prog.
IORef HandleData
-> IORef (Maybe Text) -> IORef (Maybe Text) -> Handle prog
Handle
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> IO (IORef a)
newIORef forall a b. (a -> b) -> a -> b
$ 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
                  })
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef forall a. Maybe a
Nothing
    maybeCleanup :: Maybe (Handle prog) -> IO ()
maybeCleanup = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ \Handle prog
h -> do
      HandleData
handle <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
      String -> IO ()
removeDirectoryRecursive 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.
type Handle :: Type -> Type
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.
type HandleData :: Type
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
  }

type IMarshal :: Type -> Type
newtype IMarshal a = IMarshal (State [String] a)
  deriving (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
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
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 = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall a. Show a => a -> String
show Int32
intforall a. a -> [a] -> [a]
:)
  {-# INLINABLE pushInt32 #-}

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

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

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

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

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

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

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

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

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

popMarshalT :: IMarshal a -> [String] -> a
popMarshalT :: forall a. IMarshal a -> [String] -> a
popMarshalT (IMarshal State [String] a
m) = 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) = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> s
execState State [String] a
m []
{-# INLINABLE pushMarshalT #-}

type Collect :: (Type -> Type) -> Constraint
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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. IMarshal a -> [String] -> a
popMarshalT forall a (m :: * -> *). (Marshal a, MonadPop m) => m a
pop) [[String]]
factLines
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. [a] -> Vector a
V.fromList forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> 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 <- forall (c :: * -> *) a.
(Collect c, Marshal a) =>
String -> IO (c a)
collect String
factFile
    let count :: Int
count = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
facts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall i e. Ix i => (i, i) -> [e] -> Array i e
A.listArray (Int
0, Int
count 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) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- 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
            (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
            }
    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
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Handle -> IO ()
hClose Maybe Handle
mStdOutHandle
        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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          ExitCode
ExitSuccess   -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          ExitFailure Int
c -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> ErrorCall
ErrorCall forall a b. (a -> b) -> a -> b
$ String
"Souffle exited with: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
c
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
mStdOutHandle forall a b. (a -> b) -> a -> b
$ \Handle
stdoutHandle -> do
          Text
stdout <- String -> Text
T.pack forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO String
hGetContents Handle
stdoutHandle
          forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
refHandleStdOut forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Text
stdout
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Handle
mStdErrHandle forall a b. (a -> b) -> a -> b
$ \Handle
stderrHandle -> do
          Text
stderr <- String -> Text
T.pack forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Handle -> IO String
hGetContents Handle
stderrHandle
          forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe Text)
refHandleStdErr forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' (forall prog. Handle prog -> IORef HandleData
handleData Handler SouffleM 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    HandleData -> Word64
noOfThreads forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef (forall prog. Handle prog -> IORef HandleData
handleData Handler SouffleM 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    let relationName :: String
relationName = forall a. Fact a => Proxy a -> String
factName (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 <- forall (c :: * -> *) a.
(Collect c, Marshal a) =>
String -> IO (c a)
collect String
factFile
    forall (f :: * -> *) a. Applicative f => a -> f a
pure 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] <- forall (m :: * -> *) a prog (c :: * -> *).
(MonadSouffle m, Fact a, ContainsOutputFact prog a,
 CollectFacts m c) =>
Handler m prog -> m (c a)
getFacts Handle prog
prog
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    let relationName :: String
relationName = forall a. Fact a => Proxy a -> String
factName (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 = forall a. IMarshal a -> [String]
pushMarshalT (forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push a
fact)
    String -> String -> IO ()
appendFile String
factFile forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\t" [String]
line 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    HandleData
handle <- forall a. IORef a -> IO a
readIORef forall a b. (a -> b) -> a -> b
$ forall prog. Handle prog -> IORef HandleData
handleData Handle prog
h
    let relationName :: String
relationName = forall a. Fact a => Proxy a -> String
factName (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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a. IMarshal a -> [String]
pushMarshalT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Marshal a, MonadPush m) => a -> m ()
push) (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
facts)
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\[String]
line -> String -> String -> IO ()
appendFile String
factFile (forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\t" [String]
line 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
</> forall a. Program a => a -> String
programName prog
prog String -> ShowS
<.> String
"dl"
  String -> IO Bool
doesFileExist String
dlFile forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    ExitFailure Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure 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] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
souffleBin
        [String]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
{-# INLINABLE locateSouffle #-}

readCSVFile :: FilePath -> IO [[String]]
readCSVFile :: String -> IO [[String]]
readCSVFile String
path = String -> IO Bool
doesFileExist String
path forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
False -> 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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String
contents forall a b. NFData a => a -> b -> b
`deepseq` (forall a b. (a -> b) -> [a] -> [b]
map (Char -> String -> [String]
splitOn Char
'\t') 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
c) String
s
      rest' :: String
rest' = forall a. Int -> [a] -> [a]
drop Int
1 String
rest
   in String
x forall a. a -> [a] -> [a]
: Char -> String -> [String]
splitOn Char
c String
rest'
{-# INLINABLE splitOn #-}