{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Alloy.Internal.Call (
CallAlloyConfig (maxInstances, noOverflow, timeout),
defaultCallAlloyConfig,
getRawInstances,
getRawInstancesWith,
) where
import qualified Data.ByteString as BS (
hGetLine,
intercalate,
stripPrefix,
)
import qualified Data.ByteString.Char8 as BS (unlines)
import Control.Concurrent (
threadDelay,
)
import Control.Concurrent.Async (
concurrently,
mapConcurrently_,
wait,
withAsync
)
import Control.Concurrent.Extra (Lock, newLock, withLock)
import Control.Exception (IOException, bracket, catch)
import Control.Monad (unless, when)
import Control.Monad.Extra (whenJust)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (unpack)
import Data.IORef (
IORef,
atomicWriteIORef,
#ifdef mingw32_HOST_OS
newIORef,
#endif
readIORef,
)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.Maybe (fromMaybe)
import System.Exit (ExitCode (..))
import System.FilePath
(searchPathSeparator)
import System.IO (
#ifndef mingw32_HOST_OS
BufferMode (..),
hSetBuffering,
#endif
Handle,
hClose,
hFlush,
hIsEOF,
hPutStr,
hPutStrLn,
stderr,
)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (
CreateProcess (..), StdStream (..), ProcessHandle,
cleanupProcess,
createProcess, proc, terminateProcess, waitForProcess,
)
import Language.Alloy.RessourceNames (
className, classPackage,
)
import Language.Alloy.Ressources (
alloyJar,
commonsCliJar,
slf4jJar,
)
import Paths_call_alloy (getDataDir)
data CallAlloyConfig = CallAlloyConfig {
CallAlloyConfig -> Maybe Integer
maxInstances :: !(Maybe Integer),
CallAlloyConfig -> Bool
noOverflow :: !Bool,
CallAlloyConfig -> Maybe Int
timeout :: !(Maybe Int)
}
defaultCallAlloyConfig :: CallAlloyConfig
defaultCallAlloyConfig :: CallAlloyConfig
defaultCallAlloyConfig = CallAlloyConfig {
maxInstances :: Maybe Integer
maxInstances = Maybe Integer
forall a. Maybe a
Nothing,
noOverflow :: Bool
noOverflow = Bool
True,
timeout :: Maybe Int
timeout = Maybe Int
forall a. Maybe a
Nothing
}
{-# NOINLINE outLock #-}
outLock :: Lock
outLock :: Lock
outLock = IO Lock -> Lock
forall a. IO a -> a
unsafePerformIO IO Lock
newLock
putOutLn :: String -> IO ()
putOutLn :: String -> IO ()
putOutLn = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
outLock (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
putErrLn :: String -> IO ()
putErrLn :: String -> IO ()
putErrLn = Lock -> IO () -> IO ()
forall a. Lock -> IO a -> IO a
withLock Lock
outLock (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr
getRawInstances
:: Maybe Integer
-> String
-> IO [ByteString]
getRawInstances :: Maybe Integer -> String -> IO [ByteString]
getRawInstances Maybe Integer
maxIs = CallAlloyConfig -> String -> IO [ByteString]
getRawInstancesWith CallAlloyConfig
defaultCallAlloyConfig {
maxInstances :: Maybe Integer
maxInstances = Maybe Integer
maxIs
}
callAlloyWith
:: CallAlloyConfig
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
callAlloyWith :: CallAlloyConfig
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
callAlloyWith CallAlloyConfig
config = do
String
classPath <- IO String
getClassPath
let callAlloy :: CreateProcess
callAlloy = String -> [String] -> CreateProcess
proc String
"java"
([String] -> CreateProcess) -> [String] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [String
"-cp", String
classPath, String
classPackage String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
className,
String
"-i", Integer -> String
forall a. Show a => a -> String
show (Integer -> String) -> Integer -> String
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe (-Integer
1) (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ CallAlloyConfig -> Maybe Integer
maxInstances CallAlloyConfig
config]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"-o" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CallAlloyConfig -> Bool
noOverflow CallAlloyConfig
config]
CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
callAlloy {
std_out :: StdStream
std_out = StdStream
CreatePipe,
std_in :: StdStream
std_in = StdStream
CreatePipe,
std_err :: StdStream
std_err = StdStream
CreatePipe
}
getRawInstancesWith
:: CallAlloyConfig
-> String
-> IO [ByteString]
getRawInstancesWith :: CallAlloyConfig -> String -> IO [ByteString]
getRawInstancesWith CallAlloyConfig
config String
content
= IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ())
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO [ByteString])
-> IO [ByteString]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CallAlloyConfig
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
callAlloyWith CallAlloyConfig
config) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanupProcess (((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO [ByteString])
-> IO [ByteString])
-> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO [ByteString])
-> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ \(Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p -> do
(Just Handle
hin, Just Handle
hout, Just Handle
herr, ProcessHandle
ph) <- (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
p
#ifndef mingw32_HOST_OS
Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
let abort :: Maybe a
abort = Maybe a
forall a. Maybe a
Nothing
#else
abort <- Just <$> newIORef False
#endif
let evaluateAlloy' :: IO ()
evaluateAlloy' = do
Handle -> String -> IO ()
hPutStr Handle
hin String
content
Handle -> IO ()
hFlush Handle
hin
Handle -> IO ()
hClose Handle
hin
evaluateAlloy :: IO ()
evaluateAlloy = IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO ()
evaluateAlloy' ((IOException -> IO ()) -> IO ())
-> (IOException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IOException
e -> do
let err :: String
err = IOException -> String
forall a. Show a => a -> String
show (IOException
e :: IOException)
warn :: String
warn = String
"Maybe not complete instance was sent to Alloy "
explain :: String
explain = String
"(Are timeouts set? Make sure they are not too small!): "
String -> IO ()
putErrLn (String
"Warning: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
warn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
explain String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err)
Handle
-> Handle
-> Handle
-> ProcessHandle
-> Maybe (IORef Bool)
-> Maybe Int
-> IO [ByteString]
-> IO [ByteString]
forall a.
Handle
-> Handle
-> Handle
-> ProcessHandle
-> Maybe (IORef Bool)
-> Maybe Int
-> IO a
-> IO a
withTimeout Handle
hin Handle
hout Handle
herr ProcessHandle
ph Maybe (IORef Bool)
forall a. Maybe a
abort (CallAlloyConfig -> Maybe Int
timeout CallAlloyConfig
config) (IO [ByteString] -> IO [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ do
([ByteString]
out, [ByteString]
err) <- (([ByteString], [ByteString]), ()) -> ([ByteString], [ByteString])
forall a b. (a, b) -> a
fst ((([ByteString], [ByteString]), ())
-> ([ByteString], [ByteString]))
-> IO (([ByteString], [ByteString]), ())
-> IO ([ByteString], [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ([ByteString], [ByteString])
-> IO () -> IO (([ByteString], [ByteString]), ())
forall a b. IO a -> IO b -> IO (a, b)
concurrently
(IO [ByteString]
-> IO [ByteString] -> IO ([ByteString], [ByteString])
forall a b. IO a -> IO b -> IO (a, b)
concurrently (Handle -> IO [ByteString]
getOutput Handle
hout) (Handle -> IO [ByteString]
getOutput Handle
herr))
IO ()
evaluateAlloy
Maybe (IORef Bool) -> ProcessHandle -> IO ()
printContentOnError Maybe (IORef Bool)
forall a. Maybe a
abort ProcessHandle
ph
let err' :: [ByteString]
err' = [ByteString] -> [ByteString]
removeInfoLines [ByteString]
err
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
err') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.unlines [ByteString]
err'
[ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ ([ByteString] -> ByteString) -> [[ByteString]] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\n")
([[ByteString]] -> [ByteString]) -> [[ByteString]] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ([ByteString] -> Bool) -> [[ByteString]] -> [[ByteString]]
forall {a}. (a -> Bool) -> [a] -> [a]
filterLast ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
partialInstance) (ByteString -> Bool)
-> ([ByteString] -> ByteString) -> [ByteString] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. HasCallStack => [a] -> a
last)
([[ByteString]] -> [[ByteString]])
-> [[ByteString]] -> [[ByteString]]
forall a b. (a -> b) -> a -> b
$ Int -> [[ByteString]] -> [[ByteString]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[ByteString]] -> [[ByteString]])
-> [[ByteString]] -> [[ByteString]]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString] -> [[ByteString]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [ByteString
begin] [ByteString]
out
where
begin :: ByteString
begin :: ByteString
begin = ByteString
"---INSTANCE---"
filterLast :: (a -> Bool) -> [a] -> [a]
filterLast a -> Bool
_ [] = []
filterLast a -> Bool
p x :: [a]
x@[a
_] = (a -> Bool) -> [a] -> [a]
forall {a}. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p [a]
x
filterLast a -> Bool
p (a
x:[a]
xs) = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:(a -> Bool) -> [a] -> [a]
filterLast a -> Bool
p [a]
xs
getOutput' :: Handle -> IO [ByteString]
getOutput' Handle
h = do
Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
if Bool
eof
then [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else (:) (ByteString -> [ByteString] -> [ByteString])
-> IO ByteString -> IO ([ByteString] -> [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.hGetLine Handle
h IO ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO [ByteString]
getOutput Handle
h
getOutput :: Handle -> IO [ByteString]
getOutput Handle
h = IO [ByteString]
-> (IOException -> IO [ByteString]) -> IO [ByteString]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(Handle -> IO [ByteString]
getOutput' Handle
h)
(\(IOException
_ :: IOException) -> [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
partialInstance])
printContentOnError :: Maybe (IORef Bool) -> ProcessHandle -> IO ()
printContentOnError Maybe (IORef Bool)
abort ProcessHandle
ph = do
ExitCode
code <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
Bool
aborted <- IO Bool -> (IORef Bool -> IO Bool) -> Maybe (IORef Bool) -> IO Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef Maybe (IORef Bool)
abort
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
aborted)
(IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putOutLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed parsing the Alloy code:\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
content
partialInstance :: ByteString
partialInstance :: ByteString
partialInstance = ByteString
"---PARTIAL_INSTANCE---"
removeInfoLines :: [ByteString] -> [ByteString]
removeInfoLines :: [ByteString] -> [ByteString]
removeInfoLines (ByteString
x:[ByteString]
xs)
| Just ByteString
_ <- ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"[main] INFO" ByteString
x
= [ByteString] -> [ByteString]
removeInfoLines [ByteString]
xs
| Just ByteString
_ <- ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"[main] WARN" ByteString
x
= [ByteString] -> [ByteString]
removeInfoLines [ByteString]
xs
| ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
partialInstance
= [ByteString] -> [ByteString]
removeInfoLines [ByteString]
xs
removeInfoLines [ByteString]
xs = [ByteString]
xs
withTimeout
:: Handle
-> Handle
-> Handle
-> ProcessHandle
-> Maybe (IORef Bool)
-> Maybe Int
-> IO a
-> IO a
withTimeout :: forall a.
Handle
-> Handle
-> Handle
-> ProcessHandle
-> Maybe (IORef Bool)
-> Maybe Int
-> IO a
-> IO a
withTimeout Handle
_ Handle
_ Handle
_ ProcessHandle
_ Maybe (IORef Bool)
_ Maybe Int
Nothing IO a
p = IO a
p
withTimeout Handle
i Handle
o Handle
e ProcessHandle
ph Maybe (IORef Bool)
abort (Just Int
t) IO a
p = IO a -> (Async a -> IO a) -> IO a
forall a b. IO a -> (Async a -> IO b) -> IO b
withAsync IO a
p ((Async a -> IO a) -> IO a) -> (Async a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Async a
a -> do
Int -> IO ()
threadDelay Int
t
Maybe (IORef Bool) -> (IORef Bool -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (IORef Bool)
abort (IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
`atomicWriteIORef` Bool
True)
(IO () -> IO ()) -> [IO ()] -> IO ()
forall (f :: * -> *) a b. Foldable f => (a -> IO b) -> f a -> IO ()
mapConcurrently_ IO () -> IO ()
forall a. a -> a
id [
Handle -> IO ()
hClose Handle
e,
Handle -> IO ()
hClose Handle
o,
ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph
]
Handle -> IO ()
hClose Handle
i
Async a -> IO a
forall a. Async a -> IO a
wait Async a
a
getClassPath :: IO FilePath
getClassPath :: IO String
getClassPath =
String -> String -> String -> String -> String
concatPaths (String -> String -> String -> String -> String)
-> IO String -> IO (String -> String -> String -> String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getDataDir IO (String -> String -> String -> String)
-> IO String -> IO (String -> String -> String)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO String
alloyJar IO (String -> String -> String)
-> IO String -> IO (String -> String)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO String
commonsCliJar IO (String -> String) -> IO String -> IO String
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO String
slf4jJar
where
concatPaths :: String -> String -> String -> String -> String
concatPaths String
w String
x String
y String
z = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
[Char
searchPathSeparator]
[String
w, String
x, String
y, String
z]