{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE FlexibleInstances, TypeFamilies, DerivingVia, InstanceSigs #-}
{-# LANGUAGE UndecidableInstances, RoleAnnotations #-}
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.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
type SouffleM :: Type -> Type
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)
type Config :: Type
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 stock 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
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 FilePath
"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 FilePath
"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 FilePath
"." Maybe FilePath
dlDir) Maybe FilePath
souffleBin Maybe FilePath
forall a. Maybe a
Nothing Maybe FilePath
forall a. Maybe a
Nothing
{-# INLINABLE defaultConfig #-}
runSouffle :: Program prog => prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffle :: 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 #-}
runSouffleWith
:: Program prog => Config -> prog -> (Maybe (Handle prog) -> SouffleM a) -> IO a
runSouffleWith :: 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 -> 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
Maybe FilePath
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 FilePath
datalogExecutable -> do
FilePath
tmpDir <- IO FilePath
getCanonicalTemporaryDirectory
FilePath
souffleTempDir <- FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmpDir FilePath
"souffle-haskell"
let factDir :: FilePath
factDir = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath
souffleTempDir FilePath -> ShowS
</> FilePath
"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
</> FilePath
"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
$ \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 = 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
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 #-}
type Handle :: Type -> Type
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)
}
type role Handle nominal
type HandleData :: Type
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
}
type IMarshal :: Type -> Type
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 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 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 = ([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 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 #-}
pushText :: ShortText -> IMarshal ()
pushText ShortText
txt = FilePath -> IMarshal ()
forall (m :: * -> *). MonadPush m => FilePath -> m ()
pushString (ShortText -> FilePath
TS.unpack ShortText
txt)
{-# INLINABLE pushText #-}
pushTextUtf16 :: Text -> IMarshal ()
pushTextUtf16 Text
txt = FilePath -> IMarshal ()
forall (m :: * -> *). MonadPush m => FilePath -> m ()
pushString (Text -> FilePath
T.unpack Text
txt)
{-# INLINABLE pushTextUtf16 #-}
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 FilePath
"Empty fact stack"
(FilePath
h:[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 FilePath
"Empty fact stack"
(FilePath
h:[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 FilePath
"Empty fact stack"
(FilePath
h:[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 FilePath
"Empty fact stack"
(FilePath
h:[FilePath]
t) -> (FilePath
h, [FilePath]
t)
{-# INLINABLE popString #-}
popText :: IMarshal ShortText
popText = do
FilePath
str <- ([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 FilePath
"Empty fact stack"
(FilePath
h:[FilePath]
t) -> (FilePath
h, [FilePath]
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
$ FilePath -> ShortText
TS.pack FilePath
str
{-# INLINABLE popText #-}
popTextUtf16 :: IMarshal Text
popTextUtf16 = do
FilePath
str <- ([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 FilePath
"Empty fact stack"
(FilePath
h:[FilePath]
t) -> (FilePath
h, [FilePath]
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
$ FilePath -> Text
T.pack FilePath
str
{-# INLINABLE popTextUtf16 #-}
popMarshalT :: IMarshal a -> [String] -> a
popMarshalT :: IMarshal a -> [FilePath] -> a
popMarshalT (IMarshal 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 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 #-}
type Collect :: (Type -> Type) -> Constraint
class Collect c where
collect :: Marshal a => FilePath -> IO (c a)
instance Collect [] where
collect :: FilePath -> IO [a]
collect 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 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 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 (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 :: 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
let processToRun :: CreateProcess
processToRun =
(FilePath -> CreateProcess
shell
(FilePath -> FilePath -> FilePath -> FilePath -> Word64 -> ShowS
forall r. PrintfType r => FilePath -> r
printf FilePath
"%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_ FilePath
"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
$ FilePath -> ErrorCall
ErrorCall (FilePath -> ErrorCall) -> FilePath -> ErrorCall
forall a b. (a -> b) -> a -> b
$ FilePath
"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
$ \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
$ \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 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 :: 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 :: 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 :: 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
<.> FilePath
"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
{-# INLINABLE getFacts #-}
findFact :: (Fact a, ContainsOutputFact prog a, Eq a)
=> Handle prog -> a -> SouffleM (Maybe a)
findFact :: 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 :: 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 :: 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
<.> FilePath
"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]
List.intercalate FilePath
"\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\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 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 :: 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
<.> FilePath
"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_ (\[FilePath]
line -> FilePath -> FilePath -> IO ()
appendFile FilePath
factFile (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
List.intercalate FilePath
"\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
"\n")) [[FilePath]]
factLines
{-# INLINABLE addFacts #-}
datalogProgramFile :: forall prog. Program prog => prog -> FilePath -> IO (Maybe FilePath)
datalogProgramFile :: prog -> FilePath -> IO (Maybe FilePath)
datalogProgramFile prog
prog FilePath
datalogDir = do
let dlFile :: FilePath
dlFile = FilePath
datalogDir FilePath -> ShowS
</> prog -> FilePath
forall a. Program a => a -> FilePath
programName prog
prog FilePath -> ShowS
<.> FilePath
"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
Bool
False -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
Bool
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 FilePath
"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 FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitFailure Int
_ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
ExitCode
ExitSuccess -> do
FilePath
contents <- Handle -> IO FilePath
hGetContents Handle
hout
case FilePath -> [FilePath]
words FilePath
contents of
[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
[FilePath]
_ -> 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 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
Bool
False -> [[FilePath]] -> IO [[FilePath]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Bool
True -> do
FilePath
contents <- FilePath -> IO FilePath
readFile FilePath
path
[[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 Char
'\t') ([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) FilePath
contents
{-# INLINABLE readCSVFile #-}
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
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 Char
c FilePath
s =
let (FilePath
x, 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 Int
1 FilePath
rest
in FilePath
x FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
splitOn Char
c FilePath
rest'
{-# INLINABLE splitOn #-}