call-alloy 0.2.0.6 → 0.2.1.0
raw patch · 4 files changed
+64/−15 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +4/−0
- call-alloy.cabal +2/−2
- src/Language/Alloy/Call.hs +55/−13
- test/Language/Alloy/CallSpec.hs +3/−0
ChangeLog.md view
@@ -4,6 +4,10 @@ ## Released changes +### 0.2.1.0++- enable to abort instance generation early by using timeout+ ### 0.2.0.6 - allow parsing `'` as part of words.
call-alloy.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 17a876c2f193cdf8cf992b6455dab5e37d246e48f9988f98f1c8e38d374e6dd0+-- hash: db841f71ac1e6d568aa7c8d4f6574b06cdf77fea00a6cf3ae0c74880c12eb083 name: call-alloy-version: 0.2.0.6+version: 0.2.1.0 synopsis: A simple library to call Alloy given a specification description: Please see the README on GitHub at <https://github.com/marcellussiegburg/call-alloy#readme> category: Language
src/Language/Alloy/Call.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} {-| Module : Language.Alloy.Call Description : A simple library to call Alloy given a specification@@ -14,7 +15,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Language.Alloy.Call (- CallAlloyConfig (maxInstances, noOverflow),+ CallAlloyConfig (maxInstances, noOverflow, timeout), defaultCallAlloyConfig, existsInstance, getInstances,@@ -24,13 +25,16 @@ ) where import qualified Data.ByteString as BS- (hGetLine, intercalate, writeFile)+ (hGetLine, intercalate, isSuffixOf, writeFile) import qualified Data.ByteString.Char8 as BS (unlines) -import Control.Concurrent- (forkIO, killThread, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent (+ ThreadId,+ forkIO, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay,+ )+import Control.Exception (IOException) import Control.Lens.Internal.ByteString (unpackStrict8)-import Control.Monad (unless)+import Control.Monad (unless, void, when) import Data.ByteString (ByteString) import Data.Hashable (hash) import Data.IORef (IORef, newIORef, readIORef)@@ -46,10 +50,12 @@ import System.FilePath ((</>), (<.>), searchPathSeparator, takeDirectory) import System.IO- (BufferMode (..), hClose, hFlush, hIsEOF, hPutStr, hSetBuffering)+ (BufferMode (..), Handle, hClose, hFlush, hIsEOF, hPutStr, hSetBuffering) import System.IO.Unsafe (unsafePerformIO)-import System.Process- (CreateProcess (..), StdStream (..), createProcess, proc, waitForProcess)+import System.Process (+ CreateProcess (..), StdStream (..), ProcessHandle,+ createProcess, proc, terminateProcess, waitForProcess,+ ) #if defined(mingw32_HOST_OS) import System.Win32.Info (getUserName) #else@@ -70,12 +76,17 @@ * maximal number of instances to retrieve ('Nothing' for all) * wheather to not overflow when calculating numbers within Alloy+ * an timeout after which to forcibly kill Alloy+ (retrieving only instances that were returned before killing the process) -} data CallAlloyConfig = CallAlloyConfig { -- | maximal number of instances to retrieve ('Nothing' for all) maxInstances :: Maybe Integer, -- | wheather to not overflow when calculating numbers within Alloy- noOverflow :: Bool+ noOverflow :: Bool,+ -- | the time in microseconds after which to forcibly kill Alloy+ -- ('Nothing' for never)+ timeout :: Maybe Int } {-|@@ -87,7 +98,8 @@ defaultCallAlloyConfig :: CallAlloyConfig defaultCallAlloyConfig = CallAlloyConfig { maxInstances = Nothing,- noOverflow = True+ noOverflow = True,+ timeout = Nothing } {-# NOINLINE mclassPath #-}@@ -138,6 +150,7 @@ } pout <- listenForOutput hout perr <- listenForOutput herr+ maybe (return ()) (void . startTimeout hin hout herr ph) $ timeout config #ifndef mingw32_HOST_OS hSetBuffering hin NoBuffering #endif@@ -149,18 +162,26 @@ 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+ let finstas = filterLast (not . (partialInstance `BS.isSuffixOf`)) instas+ return $ either (error . show) id . parseInstance <$> finstas where begin :: ByteString begin = "---INSTANCE---"+ partialInstance :: ByteString+ partialInstance = "---PARTIAL_INSTANCE---"+ filterLast _ [] = []+ filterLast p x@[_] = filter p x+ filterLast p (x:xs) = x:filterLast p xs getWholeOutput h = do eof <- hIsEOF h if eof then return []- else (:) <$> BS.hGetLine h <*> getWholeOutput h+ else catch+ ((:) <$> BS.hGetLine h <*> getWholeOutput h)+ (\(_ :: IOException) -> return [partialInstance]) printContentOnError ph = do code <- waitForProcess ph- unless (code == ExitSuccess)+ when (code == ExitFailure 1) $ putStrLn $ "Failed parsing the Alloy code:\n" <> content listenForOutput h = do mvar <- newEmptyMVar@@ -170,6 +191,27 @@ output <- takeMVar mvar killThread pid return output++{-|+Start a new process that aborts execution by closing all handles and+killing the processes after the given amount of time.+-}+startTimeout+ :: Handle+ -- ^ the input handle to close+ -> Handle+ -- ^ the output handle to close+ -> Handle+ -- ^ the error handle to close+ -> ProcessHandle+ -- ^ the main process handle+ -> Int -> IO ThreadId+startTimeout i o e ph t = forkIO $ do+ threadDelay t+ void $ forkIO $ hClose e+ void $ forkIO $ hClose o+ terminateProcess ph+ hClose i {-| Check if the class path was determined already, if so use it, otherwise call
test/Language/Alloy/CallSpec.hs view
@@ -10,6 +10,7 @@ import Language.Alloy.Call (existsInstance, getInstances) import Language.Alloy.Types (Entry (..), Relation (..)) +import Language.Alloy.Call (getInstancesWith, defaultCallAlloyConfig, CallAlloyConfig (..)) deriving instance Eq (Relation Set) deriving instance Eq (Entry Map Set) @@ -28,3 +29,5 @@ (show <$> getInstances (Just 2) "") `shouldReturn` "[fromList [(Signature {scope = Nothing, sigName = \"Int\"},Entry {annotation = Nothing, relation = fromList [(\"\",Single (fromList [NumberObject {number = -8},NumberObject {number = -7},NumberObject {number = -6},NumberObject {number = -5},NumberObject {number = -4},NumberObject {number = -3},NumberObject {number = -2},NumberObject {number = -1},NumberObject {number = 0},NumberObject {number = 1},NumberObject {number = 2},NumberObject {number = 3},NumberObject {number = 4},NumberObject {number = 5},NumberObject {number = 6},NumberObject {number = 7}]))]}),(Signature {scope = Nothing, sigName = \"String\"},Entry {annotation = Nothing, relation = fromList [(\"\",EmptyRelation)]}),(Signature {scope = Nothing, sigName = \"integers\"},Entry {annotation = Nothing, relation = fromList [(\"\",Single (fromList [NumberObject {number = -8},NumberObject {number = -7},NumberObject {number = -6},NumberObject {number = -5},NumberObject {number = -4},NumberObject {number = -3},NumberObject {number = -2},NumberObject {number = -1},NumberObject {number = 0},NumberObject {number = 1},NumberObject {number = 2},NumberObject {number = 3},NumberObject {number = 4},NumberObject {number = 5},NumberObject {number = 6},NumberObject {number = 7}]))]}),(Signature {scope = Nothing, sigName = \"none\"},Entry {annotation = Nothing, relation = fromList [(\"\",EmptyRelation)]}),(Signature {scope = Nothing, sigName = \"univ\"},Entry {annotation = Nothing, relation = fromList [(\"\",Single (fromList [NumberObject {number = -8},NumberObject {number = -7},NumberObject {number = -6},NumberObject {number = -5},NumberObject {number = -4},NumberObject {number = -3},NumberObject {number = -2},NumberObject {number = -1},NumberObject {number = 0},NumberObject {number = 1},NumberObject {number = 2},NumberObject {number = 3},NumberObject {number = 4},NumberObject {number = 5},NumberObject {number = 6},NumberObject {number = 7}]))]}),(Signature {scope = Just \"seq\", sigName = \"Int\"},Entry {annotation = Nothing, relation = fromList [(\"\",Single (fromList [NumberObject {number = 0},NumberObject {number = 1},NumberObject {number = 2},NumberObject {number = 3}]))]})]]" it "a conflicting spec returns no instance" $ getInstances (Just 1) "pred a (a: Int) { a > a }\nrun a" `shouldReturn` []+ it "a conflicting spec returns error" $+ getInstancesWith defaultCallAlloyConfig {maxInstances = Just 1, timeout = Just 1} "pred a (a: Int) { a > a }\nrun a" `shouldReturn` []