{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# LANGUAGE DataKinds, FlexibleContexts, TypeFamilies, DerivingVia, InstanceSigs #-}
module Language.Souffle.Interpreted
( Program(..)
, Fact(..)
, Marshal(..)
, Config(..)
, Handle
, SouffleM
, MonadSouffle(..)
, runSouffle
, runSouffleWith
, defaultConfig
, cleanup
) where
import Prelude hiding (init)
import Control.DeepSeq (deepseq)
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.IORef
import Data.Foldable (traverse_)
import Data.List hiding (init)
import Data.Semigroup (Last(..))
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Vector as V
import Data.Word
import Language.Souffle.Class
import Language.Souffle.Marshal
import System.Directory
import System.Environment
import System.Exit
import System.FilePath
import System.IO (hGetContents)
import System.IO.Temp
import System.Process
import Text.Printf
newtype SouffleM a
= SouffleM (ReaderT Config IO a)
deriving (a -> SouffleM b -> SouffleM a
(a -> b) -> SouffleM a -> SouffleM b
(forall a b. (a -> b) -> SouffleM a -> SouffleM b)
-> (forall a b. a -> SouffleM b -> SouffleM a) -> Functor SouffleM
forall a b. a -> SouffleM b -> SouffleM a
forall a b. (a -> b) -> SouffleM a -> SouffleM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SouffleM b -> SouffleM a
$c<$ :: forall a b. a -> SouffleM b -> SouffleM a
fmap :: (a -> b) -> SouffleM a -> SouffleM b
$cfmap :: forall a b. (a -> b) -> SouffleM a -> SouffleM b
Functor, Functor SouffleM
a -> SouffleM a
Functor SouffleM =>
(forall a. a -> SouffleM a)
-> (forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b)
-> (forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM b)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM a)
-> Applicative SouffleM
SouffleM a -> SouffleM b -> SouffleM b
SouffleM a -> SouffleM b -> SouffleM a
SouffleM (a -> b) -> SouffleM a -> SouffleM b
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
forall a. a -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM b
forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SouffleM a -> SouffleM b -> SouffleM a
$c<* :: forall a b. SouffleM a -> SouffleM b -> SouffleM a
*> :: SouffleM a -> SouffleM b -> SouffleM b
$c*> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
liftA2 :: (a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> SouffleM a -> SouffleM b -> SouffleM c
<*> :: SouffleM (a -> b) -> SouffleM a -> SouffleM b
$c<*> :: forall a b. SouffleM (a -> b) -> SouffleM a -> SouffleM b
pure :: a -> SouffleM a
$cpure :: forall a. a -> SouffleM a
$cp1Applicative :: Functor SouffleM
Applicative, Applicative SouffleM
a -> SouffleM a
Applicative SouffleM =>
(forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b)
-> (forall a b. SouffleM a -> SouffleM b -> SouffleM b)
-> (forall a. a -> SouffleM a)
-> Monad SouffleM
SouffleM a -> (a -> SouffleM b) -> SouffleM b
SouffleM a -> SouffleM b -> SouffleM b
forall a. a -> SouffleM a
forall a b. SouffleM a -> SouffleM b -> SouffleM b
forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SouffleM a
$creturn :: forall a. a -> SouffleM a
>> :: SouffleM a -> SouffleM b -> SouffleM b
$c>> :: forall a b. SouffleM a -> SouffleM b -> SouffleM b
>>= :: SouffleM a -> (a -> SouffleM b) -> SouffleM b
$c>>= :: forall a b. SouffleM a -> (a -> SouffleM b) -> SouffleM b
$cp1Monad :: Applicative SouffleM
Monad, Monad SouffleM
Monad SouffleM =>
(forall a. IO a -> SouffleM a) -> MonadIO SouffleM
IO a -> SouffleM a
forall a. IO a -> SouffleM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> SouffleM a
$cliftIO :: forall a. IO a -> SouffleM a
$cp1MonadIO :: Monad SouffleM
MonadIO)
via (ReaderT Config IO)
data Config
= Config
{ Config -> FilePath
cfgDatalogDir :: FilePath
, Config -> Maybe FilePath
cfgSouffleBin :: Maybe FilePath
} deriving Int -> Config -> ShowS
[Config] -> ShowS
Config -> FilePath
(Int -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Config] -> ShowS
$cshowList :: [Config] -> ShowS
show :: Config -> FilePath
$cshow :: Config -> FilePath
showsPrec :: Int -> Config -> ShowS
$cshowsPrec :: Int -> Config -> ShowS
Show
defaultConfig :: MonadIO m => m Config
defaultConfig :: m Config
defaultConfig = IO Config -> m Config
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Config -> m Config) -> IO Config -> m Config
forall a b. (a -> b) -> a -> b
$ do
Maybe FilePath
dlDir <- FilePath -> IO (Maybe FilePath)
lookupEnv "DATALOG_DIR"
Maybe (Last FilePath)
envSouffleBin <- (FilePath -> Last FilePath)
-> Maybe FilePath -> Maybe (Last FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Last FilePath
forall a. a -> Last a
Last (Maybe FilePath -> Maybe (Last FilePath))
-> IO (Maybe FilePath) -> IO (Maybe (Last FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Maybe FilePath)
lookupEnv "SOUFFLE_BIN"
Maybe (Last FilePath)
locatedBin <- (FilePath -> Last FilePath)
-> Maybe FilePath -> Maybe (Last FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Last FilePath
forall a. a -> Last a
Last (Maybe FilePath -> Maybe (Last FilePath))
-> IO (Maybe FilePath) -> IO (Maybe (Last FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe FilePath)
locateSouffle
let souffleBin :: Maybe FilePath
souffleBin = Last FilePath -> FilePath
forall a. Last a -> a
getLast (Last FilePath -> FilePath)
-> Maybe (Last FilePath) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Last FilePath)
locatedBin Maybe (Last FilePath)
-> Maybe (Last FilePath) -> Maybe (Last FilePath)
forall a. Semigroup a => a -> a -> a
<> Maybe (Last FilePath)
envSouffleBin
Config -> IO Config
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath -> Config
Config (FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe "." Maybe FilePath
dlDir) Maybe FilePath
souffleBin
{-# INLINABLE defaultConfig #-}
runSouffle :: SouffleM a -> IO a
runSouffle :: SouffleM a -> IO a
runSouffle m :: SouffleM a
m = do
Config
cfg <- IO Config
forall (m :: * -> *). MonadIO m => m Config
defaultConfig
Config -> SouffleM a -> IO a
forall a. Config -> SouffleM a -> IO a
runSouffleWith Config
cfg SouffleM a
m
{-# INLINABLE runSouffle #-}
runSouffleWith :: Config -> SouffleM a -> IO a
runSouffleWith :: Config -> SouffleM a -> IO a
runSouffleWith cfg :: Config
cfg (SouffleM m :: ReaderT Config IO a
m) = ReaderT Config IO a -> Config -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Config IO a
m Config
cfg
{-# INLINABLE runSouffleWith #-}
newtype Handle prog = Handle (IORef HandleData)
data HandleData = HandleData
{ HandleData -> FilePath
soufflePath :: FilePath
, HandleData -> FilePath
basePath :: FilePath
, HandleData -> FilePath
factPath :: FilePath
, HandleData -> FilePath
outputPath :: FilePath
, HandleData -> FilePath
datalogExec :: FilePath
, HandleData -> Word64
noOfThreads :: Word64
}
newtype IMarshal a = IMarshal (State [String] a)
deriving
( a -> IMarshal b -> IMarshal a
(a -> b) -> IMarshal a -> IMarshal b
(forall a b. (a -> b) -> IMarshal a -> IMarshal b)
-> (forall a b. a -> IMarshal b -> IMarshal a) -> Functor IMarshal
forall a b. a -> IMarshal b -> IMarshal a
forall a b. (a -> b) -> IMarshal a -> IMarshal b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> IMarshal b -> IMarshal a
$c<$ :: forall a b. a -> IMarshal b -> IMarshal a
fmap :: (a -> b) -> IMarshal a -> IMarshal b
$cfmap :: forall a b. (a -> b) -> IMarshal a -> IMarshal b
Functor
, Functor IMarshal
a -> IMarshal a
Functor IMarshal =>
(forall a. a -> IMarshal a)
-> (forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b)
-> (forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal b)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal a)
-> Applicative IMarshal
IMarshal a -> IMarshal b -> IMarshal b
IMarshal a -> IMarshal b -> IMarshal a
IMarshal (a -> b) -> IMarshal a -> IMarshal b
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
forall a. a -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal b
forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: IMarshal a -> IMarshal b -> IMarshal a
$c<* :: forall a b. IMarshal a -> IMarshal b -> IMarshal a
*> :: IMarshal a -> IMarshal b -> IMarshal b
$c*> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
liftA2 :: (a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
$cliftA2 :: forall a b c.
(a -> b -> c) -> IMarshal a -> IMarshal b -> IMarshal c
<*> :: IMarshal (a -> b) -> IMarshal a -> IMarshal b
$c<*> :: forall a b. IMarshal (a -> b) -> IMarshal a -> IMarshal b
pure :: a -> IMarshal a
$cpure :: forall a. a -> IMarshal a
$cp1Applicative :: Functor IMarshal
Applicative
, Applicative IMarshal
a -> IMarshal a
Applicative IMarshal =>
(forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b)
-> (forall a b. IMarshal a -> IMarshal b -> IMarshal b)
-> (forall a. a -> IMarshal a)
-> Monad IMarshal
IMarshal a -> (a -> IMarshal b) -> IMarshal b
IMarshal a -> IMarshal b -> IMarshal b
forall a. a -> IMarshal a
forall a b. IMarshal a -> IMarshal b -> IMarshal b
forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> IMarshal a
$creturn :: forall a. a -> IMarshal a
>> :: IMarshal a -> IMarshal b -> IMarshal b
$c>> :: forall a b. IMarshal a -> IMarshal b -> IMarshal b
>>= :: IMarshal a -> (a -> IMarshal b) -> IMarshal b
$c>>= :: forall a b. IMarshal a -> (a -> IMarshal b) -> IMarshal b
$cp1Monad :: Applicative IMarshal
Monad
, MonadState [String]
)
via (State [String])
popMarshalT :: MarshalM PopF a -> [String] -> a
popMarshalT :: MarshalM PopF a -> [FilePath] -> a
popMarshalT = IMarshal a -> [FilePath] -> a
forall a. IMarshal a -> [FilePath] -> a
runM (IMarshal a -> [FilePath] -> a)
-> (MarshalM PopF a -> IMarshal a)
-> MarshalM PopF a
-> [FilePath]
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. PopF x -> IMarshal x) -> MarshalM PopF a -> IMarshal a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> MarshalM f a -> m a
interpret forall x. PopF x -> IMarshal x
forall (m :: * -> *) a. MonadState [FilePath] m => PopF a -> m a
popAlgM where
runM :: IMarshal a -> [FilePath] -> a
runM (IMarshal m :: State [FilePath] a
m) = State [FilePath] a -> [FilePath] -> a
forall s a. State s a -> s -> a
evalState State [FilePath] a
m
popAlgM :: PopF a -> m a
popAlgM (PopStr f :: FilePath -> a
f) = do
FilePath
str <- ([FilePath] -> (FilePath, [FilePath])) -> m FilePath
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\case
[] -> FilePath -> (FilePath, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
(h :: FilePath
h:t :: [FilePath]
t) -> (FilePath
h, [FilePath]
t))
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ FilePath -> a
f FilePath
str
popAlgM (PopInt f :: Int32 -> a
f) = do
Int32
int <- ([FilePath] -> (Int32, [FilePath])) -> m Int32
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state (\case
[] -> FilePath -> (Int32, [FilePath])
forall a. HasCallStack => FilePath -> a
error "Empty fact stack"
(h :: FilePath
h:t :: [FilePath]
t) -> (FilePath -> Int32
forall a. Read a => FilePath -> a
read FilePath
h, [FilePath]
t))
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> m a) -> a -> m a
forall a b. (a -> b) -> a -> b
$ Int32 -> a
f Int32
int
{-# INLINABLE popMarshalT #-}
pushMarshalT :: MarshalM PushF a -> [String]
pushMarshalT :: MarshalM PushF a -> [FilePath]
pushMarshalT = IMarshal a -> [FilePath]
forall a. IMarshal a -> [FilePath]
runM (IMarshal a -> [FilePath])
-> (MarshalM PushF a -> IMarshal a)
-> MarshalM PushF a
-> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. PushF x -> IMarshal x) -> MarshalM PushF a -> IMarshal a
forall (m :: * -> *) (f :: * -> *) a.
Monad m =>
(forall x. f x -> m x) -> MarshalM f a -> m a
interpret forall x. PushF x -> IMarshal x
forall (m :: * -> *) a. MonadState [FilePath] m => PushF a -> m a
pushAlgM where
runM :: IMarshal a -> [FilePath]
runM (IMarshal m :: State [FilePath] a
m) = [FilePath] -> [FilePath]
forall a. [a] -> [a]
reverse ([FilePath] -> [FilePath]) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ State [FilePath] a -> [FilePath] -> [FilePath]
forall s a. State s a -> s -> s
execState State [FilePath] a
m []
pushAlgM :: PushF a -> m a
pushAlgM (PushInt i :: Int32
i v :: a
v) = do
([FilePath] -> [FilePath]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Int32 -> FilePath
forall a. Show a => a -> FilePath
show Int32
iFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
pushAlgM (PushStr s :: FilePath
s v :: a
v) = do
([FilePath] -> [FilePath]) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath
sFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:)
a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
{-# INLINABLE pushMarshalT #-}
class Collect c where
collect :: Marshal a => FilePath -> IO (c a)
instance Collect [] where
collect :: FilePath -> IO [a]
collect factFile :: FilePath
factFile = do
[[FilePath]]
factLines <- FilePath -> IO [[FilePath]]
readCSVFile FilePath
factFile
let facts :: [a]
facts = ([FilePath] -> a) -> [[FilePath]] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (MarshalM PopF a -> [FilePath] -> a
forall a. MarshalM PopF a -> [FilePath] -> a
popMarshalT MarshalM PopF a
forall a. Marshal a => MarshalM PopF a
pop) [[FilePath]]
factLines
[a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$! [a]
facts
{-# INLINABLE collect #-}
instance Collect V.Vector where
collect :: FilePath -> IO (Vector a)
collect factFile :: FilePath
factFile = [a] -> Vector a
forall a. [a] -> Vector a
V.fromList ([a] -> Vector a) -> IO [a] -> IO (Vector a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> FilePath -> IO [a]
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
FilePath -> IO (c a)
collect FilePath
factFile
{-# INLINABLE collect #-}
instance MonadSouffle SouffleM where
type Handler SouffleM = Handle
type CollectFacts SouffleM c = Collect c
init :: forall prog. Program prog => prog -> SouffleM (Maybe (Handle prog))
init :: prog -> SouffleM (Maybe (Handle prog))
init prg :: prog
prg = ReaderT Config IO (Maybe (Handle prog))
-> SouffleM (Maybe (Handle prog))
forall a. ReaderT Config IO a -> SouffleM a
SouffleM (ReaderT Config IO (Maybe (Handle prog))
-> SouffleM (Maybe (Handle prog)))
-> ReaderT Config IO (Maybe (Handle prog))
-> SouffleM (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ prog -> ReaderT Config IO (Maybe FilePath)
forall prog.
Program prog =>
prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile prog
prg ReaderT Config IO (Maybe FilePath)
-> (Maybe FilePath -> ReaderT Config IO (Maybe (Handle prog)))
-> ReaderT Config IO (Maybe (Handle prog))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Nothing -> Maybe (Handle prog) -> ReaderT Config IO (Maybe (Handle prog))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Handle prog)
forall a. Maybe a
Nothing
Just datalogExecutable :: FilePath
datalogExecutable -> do
FilePath
souffleTempDir <- IO FilePath -> ReaderT Config IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ReaderT Config IO FilePath)
-> IO FilePath -> ReaderT Config IO FilePath
forall a b. (a -> b) -> a -> b
$ do
FilePath
tmpDir <- IO FilePath
getCanonicalTemporaryDirectory
FilePath -> FilePath -> IO FilePath
createTempDirectory FilePath
tmpDir "souffle-haskell"
let factDir :: FilePath
factDir = FilePath
souffleTempDir FilePath -> ShowS
</> "fact"
outDir :: FilePath
outDir = FilePath
souffleTempDir FilePath -> ShowS
</> "out"
IO () -> ReaderT Config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Config IO ()) -> IO () -> ReaderT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
factDir
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
outDir
Maybe FilePath
mSouffleBin <- (Config -> Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> Maybe FilePath
cfgSouffleBin
IO (Maybe (Handle prog)) -> ReaderT Config IO (Maybe (Handle prog))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Handle prog))
-> ReaderT Config IO (Maybe (Handle prog)))
-> IO (Maybe (Handle prog))
-> ReaderT Config IO (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
-> (FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Maybe FilePath
mSouffleBin ((FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog)))
-> (FilePath -> IO (Handle prog)) -> IO (Maybe (Handle prog))
forall a b. (a -> b) -> a -> b
$ \souffleBin :: FilePath
souffleBin ->
(IORef HandleData -> Handle prog)
-> IO (IORef HandleData) -> IO (Handle prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef HandleData -> Handle prog
forall prog. IORef HandleData -> Handle prog
Handle (IO (IORef HandleData) -> IO (Handle prog))
-> IO (IORef HandleData) -> IO (Handle prog)
forall a b. (a -> b) -> a -> b
$ HandleData -> IO (IORef HandleData)
forall a. a -> IO (IORef a)
newIORef (HandleData -> IO (IORef HandleData))
-> HandleData -> IO (IORef HandleData)
forall a b. (a -> b) -> a -> b
$ HandleData :: FilePath
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Word64
-> HandleData
HandleData
{ soufflePath :: FilePath
soufflePath = FilePath
souffleBin
, basePath :: FilePath
basePath = FilePath
souffleTempDir
, factPath :: FilePath
factPath = FilePath
factDir
, outputPath :: FilePath
outputPath = FilePath
outDir
, datalogExec :: FilePath
datalogExec = FilePath
datalogExecutable
, noOfThreads :: Word64
noOfThreads = 1
}
{-# INLINABLE init #-}
run :: Handler SouffleM prog -> SouffleM ()
run (Handle ref) = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
FilePath -> IO ()
callCommand (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
FilePath -> FilePath -> FilePath -> FilePath -> Word64 -> ShowS
forall r. PrintfType r => FilePath -> r
printf "%s -F%s -D%s -j%d %s"
(HandleData -> FilePath
soufflePath HandleData
handle)
(HandleData -> FilePath
factPath HandleData
handle)
(HandleData -> FilePath
outputPath HandleData
handle)
(HandleData -> Word64
noOfThreads HandleData
handle)
(HandleData -> FilePath
datalogExec HandleData
handle)
{-# INLINABLE run #-}
setNumThreads :: Handler SouffleM prog -> Word64 -> SouffleM ()
setNumThreads (Handle ref) n :: Word64
n = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$
IORef HandleData -> (HandleData -> HandleData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef HandleData
ref (\h :: HandleData
h -> HandleData
h { noOfThreads :: Word64
noOfThreads = Word64
n })
{-# INLINABLE setNumThreads #-}
getNumThreads :: Handler SouffleM prog -> SouffleM Word64
getNumThreads (Handle ref) = IO Word64 -> SouffleM Word64
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word64 -> SouffleM Word64) -> IO Word64 -> SouffleM Word64
forall a b. (a -> b) -> a -> b
$
HandleData -> Word64
noOfThreads (HandleData -> Word64) -> IO HandleData -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
{-# INLINABLE getNumThreads #-}
getFacts :: forall a c prog. (Marshal a, Fact a, ContainsFact prog a, Collect c)
=> Handle prog -> SouffleM (c a)
getFacts :: Handle prog -> SouffleM (c a)
getFacts (Handle ref :: IORef HandleData
ref) = IO (c a) -> SouffleM (c a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (c a) -> SouffleM (c a)) -> IO (c a) -> SouffleM (c a)
forall a b. (a -> b) -> a -> b
$ do
HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
let factFile :: FilePath
factFile = HandleData -> FilePath
outputPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "csv"
c a
facts <- FilePath -> IO (c a)
forall (c :: * -> *) a.
(Collect c, Marshal a) =>
FilePath -> IO (c a)
collect FilePath
factFile
c a -> IO (c a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c a -> IO (c a)) -> c a -> IO (c a)
forall a b. (a -> b) -> a -> b
$! c a
facts
{-# INLINABLE getFacts #-}
findFact :: (Fact a, ContainsFact prog a, Eq a)
=> Handle prog -> a -> SouffleM (Maybe a)
findFact :: Handle prog -> a -> SouffleM (Maybe a)
findFact prog :: Handle prog
prog fact :: a
fact = do
[a]
facts :: [a] <- Handler SouffleM prog -> SouffleM [a]
forall (m :: * -> *) a prog (c :: * -> *).
(MonadSouffle m, Fact a, ContainsFact prog a, CollectFacts m c) =>
Handler m prog -> m (c a)
getFacts Handler SouffleM prog
Handle prog
prog
Maybe a -> SouffleM (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> SouffleM (Maybe a)) -> Maybe a -> SouffleM (Maybe a)
forall a b. (a -> b) -> a -> b
$ (a -> Bool) -> [a] -> Maybe a
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
fact) [a]
facts
{-# INLINABLE findFact #-}
addFact :: forall a prog. (Fact a, ContainsFact prog a, Marshal a)
=> Handle prog -> a -> SouffleM ()
addFact :: Handle prog -> a -> SouffleM ()
addFact (Handle ref :: IORef HandleData
ref) fact :: a
fact = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
let factFile :: FilePath
factFile = HandleData -> FilePath
factPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "facts"
let line :: [FilePath]
line = MarshalM PushF () -> [FilePath]
forall a. MarshalM PushF a -> [FilePath]
pushMarshalT (a -> MarshalM PushF ()
forall a. Marshal a => a -> MarshalM PushF ()
push a
fact)
FilePath -> FilePath -> IO ()
appendFile FilePath
factFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
{-# INLINABLE addFact #-}
addFacts :: forall a prog f. (Fact a, ContainsFact prog a, Marshal a, Foldable f)
=> Handle prog -> f a -> SouffleM ()
addFacts :: Handle prog -> f a -> SouffleM ()
addFacts (Handle ref :: IORef HandleData
ref) facts :: f a
facts = ReaderT Config IO () -> SouffleM ()
forall a. ReaderT Config IO a -> SouffleM a
SouffleM (ReaderT Config IO () -> SouffleM ())
-> ReaderT Config IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT Config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Config IO ()) -> IO () -> ReaderT Config IO ()
forall a b. (a -> b) -> a -> b
$ do
HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
let relationName :: FilePath
relationName = Proxy a -> FilePath
forall a. Fact a => Proxy a -> FilePath
factName (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
let factFile :: FilePath
factFile = HandleData -> FilePath
factPath HandleData
handle FilePath -> ShowS
</> FilePath
relationName FilePath -> ShowS
<.> "facts"
let factLines :: [[FilePath]]
factLines = (a -> [FilePath]) -> [a] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (MarshalM PushF () -> [FilePath]
forall a. MarshalM PushF a -> [FilePath]
pushMarshalT (MarshalM PushF () -> [FilePath])
-> (a -> MarshalM PushF ()) -> a -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MarshalM PushF ()
forall a. Marshal a => a -> MarshalM PushF ()
push) ((a -> [a]) -> f a -> [a]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure f a
facts)
([FilePath] -> IO ()) -> [[FilePath]] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\line :: [FilePath]
line -> FilePath -> FilePath -> IO ()
appendFile FilePath
factFile (FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\t" [FilePath]
line FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")) [[FilePath]]
factLines
{-# INLINABLE addFacts #-}
datalogProgramFile :: forall prog. Program prog => prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile :: prog -> ReaderT Config IO (Maybe FilePath)
datalogProgramFile _ = do
FilePath
dir <- (Config -> FilePath) -> ReaderT Config IO FilePath
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Config -> FilePath
cfgDatalogDir
let dlFile :: FilePath
dlFile = FilePath
dir FilePath -> ShowS
</> Proxy prog -> FilePath
forall a. Program a => Proxy a -> FilePath
programName (Proxy prog
forall k (t :: k). Proxy t
Proxy :: Proxy prog) FilePath -> ShowS
<.> "dl"
IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath))
-> IO (Maybe FilePath) -> ReaderT Config IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
dlFile IO Bool -> (Bool -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
False -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
True -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dlFile
{-# INLINABLE datalogProgramFile #-}
locateSouffle :: IO (Maybe FilePath)
locateSouffle :: IO (Maybe FilePath)
locateSouffle = do
let locateCmd :: CreateProcess
locateCmd = (FilePath -> CreateProcess
shell "which souffle") { std_out :: StdStream
std_out = StdStream
CreatePipe }
(_, Just hout :: Handle
hout, _, locateCmdHandle :: ProcessHandle
locateCmdHandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
locateCmd
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
locateCmdHandle IO ExitCode
-> (ExitCode -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
ExitFailure _ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
ExitSuccess ->
FilePath -> [FilePath]
words (FilePath -> [FilePath]) -> IO FilePath -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO FilePath
hGetContents Handle
hout IO [FilePath]
-> ([FilePath] -> IO (Maybe FilePath)) -> IO (Maybe FilePath)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[souffleBin :: FilePath
souffleBin] -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
souffleBin
_ -> Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing
{-# INLINABLE locateSouffle #-}
readCSVFile :: FilePath -> IO [[String]]
readCSVFile :: FilePath -> IO [[FilePath]]
readCSVFile path :: FilePath
path = FilePath -> IO Bool
doesFileExist FilePath
path IO Bool -> (Bool -> IO [[FilePath]]) -> IO [[FilePath]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
False -> [[FilePath]] -> IO [[FilePath]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
True -> do
FilePath
contents <- FilePath -> IO FilePath
readFile FilePath
path
[[FilePath]] -> IO [[FilePath]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([[FilePath]] -> IO [[FilePath]])
-> [[FilePath]] -> IO [[FilePath]]
forall a b. (a -> b) -> a -> b
$ FilePath
contents FilePath -> [[FilePath]] -> [[FilePath]]
forall a b. NFData a => a -> b -> b
`deepseq` ((FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map (Char -> FilePath -> [FilePath]
splitOn '\t') ([FilePath] -> [[FilePath]])
-> (FilePath -> [FilePath]) -> FilePath -> [[FilePath]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines) FilePath
contents
{-# INLINABLE readCSVFile #-}
cleanup :: forall prog. Program prog => Handle prog -> SouffleM ()
cleanup :: Handle prog -> SouffleM ()
cleanup (Handle ref :: IORef HandleData
ref) = IO () -> SouffleM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> SouffleM ()) -> IO () -> SouffleM ()
forall a b. (a -> b) -> a -> b
$ do
HandleData
handle <- IORef HandleData -> IO HandleData
forall a. IORef a -> IO a
readIORef IORef HandleData
ref
(FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ FilePath -> IO ()
removeDirectoryRecursive [HandleData -> FilePath
factPath HandleData
handle, HandleData -> FilePath
outputPath HandleData
handle, HandleData -> FilePath
basePath HandleData
handle]
{-# INLINABLE cleanup #-}
splitOn :: Char -> String -> [String]
splitOn :: Char -> FilePath -> [FilePath]
splitOn c :: Char
c s :: FilePath
s =
let (x :: FilePath
x, rest :: FilePath
rest) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) FilePath
s
rest' :: FilePath
rest' = Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1 FilePath
rest
in FilePath
x FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
splitOn Char
c FilePath
rest'
{-# INLINABLE splitOn #-}