summaryrefslogtreecommitdiff
path: root/src/Language/Alloy/Call.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/Alloy/Call.hs')
-rw-r--r--src/Language/Alloy/Call.hs41
1 files changed, 28 insertions, 13 deletions
diff --git a/src/Language/Alloy/Call.hs b/src/Language/Alloy/Call.hs
index 83b765e..15da31e 100644
--- a/src/Language/Alloy/Call.hs
+++ b/src/Language/Alloy/Call.hs
@@ -22,27 +22,31 @@ module Language.Alloy.Call (
import qualified Data.ByteString as BS
(hGetLine, intercalate, writeFile)
+import qualified Data.ByteString.Char8 as BS (unlines)
-import Control.Monad (unless)
+import Control.Concurrent
+ (forkIO, killThread, newEmptyMVar, putMVar, takeMVar)
import Control.Lens.Internal.ByteString (unpackStrict8)
+import Control.Monad (unless)
import Data.ByteString (ByteString)
import Data.Hashable (hash)
import Data.IORef (IORef, newIORef, readIORef)
import Data.List.Split (splitOn)
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (fromMaybe)
import System.Directory
(XdgDirectory (..), createDirectory, doesFileExist, doesDirectoryExist,
getTemporaryDirectory, getXdgDirectory)
import System.Directory.Internal (setFileMode)
import System.Directory.Internal.Prelude
(catch, isDoesNotExistError)
-import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.FilePath
((</>), (<.>), searchPathSeparator, takeDirectory)
-import System.IO (hClose, hIsEOF, hPutStr)
+import System.IO
+ (BufferMode (..), hClose, hFlush, hIsEOF, hPutStr, hSetBuffering)
import System.IO.Unsafe (unsafePerformIO)
import System.Process
+ (CreateProcess (..), StdStream (..), createProcess, proc, waitForProcess)
#if defined(mingw32_HOST_OS)
import System.Win32.Info (getUserName)
#else
@@ -71,8 +75,8 @@ mclassPath = unsafePerformIO (newIORef Nothing)
{-|
This function may be used to get all model instances for a given Alloy
-specification. It calls Alloy via a Java interface and returns the raw instance
-answers as list of 'String's.
+specification. It calls Alloy via a Java interface and parses the raw instance
+answers before returning the resulting list of 'AlloyInstance's.
-}
getInstances
:: Maybe Integer
@@ -91,11 +95,17 @@ getInstances maxInstances content = do
std_in = CreatePipe,
std_err = CreatePipe
}
+ pout <- listenForOutput hout
+ perr <- listenForOutput herr
+ hSetBuffering hin NoBuffering
hPutStr hin content
+ hFlush hin
hClose hin
- printCallErrors herr
- instas <- printContentOnError ph `seq`
- fmap (BS.intercalate "\n") . drop 1 . splitOn [begin] <$> getWholeOutput hout
+ out <- getOutput pout
+ err <- getOutput perr
+ printContentOnError ph
+ unless (null err) $ fail $ unpackStrict8 $ BS.unlines err
+ let instas = fmap (BS.intercalate "\n") $ drop 1 $ splitOn [begin] out
return $ either (error . show) id . parseInstance <$> instas
where
begin :: ByteString
@@ -108,10 +118,15 @@ getInstances maxInstances content = do
printContentOnError ph = do
code <- waitForProcess ph
unless (code == ExitSuccess)
- $ fail $ "Failed parsing your file:\n" <> content
- printCallErrors err = do
- errors <- getWholeOutput err
- unless (null errors) $ fail $ unpackStrict8 $ BS.intercalate "\n" errors
+ $ fail $ "Failed parsing the Alloy code:\n" <> content
+ listenForOutput h = do
+ mvar <- newEmptyMVar
+ pid <- forkIO $ getWholeOutput h >>= putMVar mvar
+ return (pid, mvar)
+ getOutput (pid, mvar) = do
+ output <- takeMVar mvar
+ killThread pid
+ return output
{-|
Check if the class path was determined already, if so use it, otherwise call