diff --git a/src/System/ZMQ4/Monadic.hs b/src/System/ZMQ4/Monadic.hs --- a/src/System/ZMQ4/Monadic.hs +++ b/src/System/ZMQ4/Monadic.hs @@ -227,8 +227,10 @@ instance MonadIO (ZMQ z) where liftIO m = ZMQ $! liftIO m +instance MonadThrow (ZMQ z) where + throwM = ZMQ . C.throwM + instance MonadCatch (ZMQ z) where - throwM = ZMQ . C.throwM catch (ZMQ m) f = ZMQ $ m `C.catch` (_unzmq . f) mask a = ZMQ . ReaderT $ \env -> diff --git a/tests/System/ZMQ4/Test/Properties.hs b/tests/System/ZMQ4/Test/Properties.hs --- a/tests/System/ZMQ4/Test/Properties.hs +++ b/tests/System/ZMQ4/Test/Properties.hs @@ -6,8 +6,9 @@ module System.ZMQ4.Test.Properties where import Test.QuickCheck -import Test.QuickCheck.Monadic -import Test.Tools +import Test.QuickCheck.Monadic (monadicIO, run) +import Test.Tasty +import Test.Tasty.QuickCheck import Control.Applicative import Control.Concurrent.Async (wait) @@ -18,50 +19,51 @@ import Data.ByteString (ByteString) import System.ZMQ4.Monadic import System.Posix.Types (Fd(..)) -import qualified Data.ByteString as SB -import qualified Data.ByteString.Char8 as CB -tests :: IO () -tests = do - quickBatch' ("0MQ Socket Properties" - , [ ("get socket option (Pair)", property $ prop_get_socket_option Pair) - , ("get socket option (Pub)", property $ prop_get_socket_option Pub) - , ("get socket option (Sub)", property $ prop_get_socket_option Sub) - , ("get socket option (XPub)", property $ prop_get_socket_option XPub) - , ("get socket option (XSub)", property $ prop_get_socket_option XSub) - , ("get socket option (Req)", property $ prop_get_socket_option Req) - , ("get socket option (Rep)", property $ prop_get_socket_option Rep) - , ("get socket option (Dealer)", property $ prop_get_socket_option Dealer) - , ("get socket option (Router)", property $ prop_get_socket_option Router) - , ("get socket option (Pull)", property $ prop_get_socket_option Pull) - , ("get socket option (Push)", property $ prop_get_socket_option Push) - , ("set;get socket option (Pair)", property $ prop_set_get_socket_option Pair) - , ("set;get socket option (Pub)", property $ prop_set_get_socket_option Pub) - , ("set;get socket option (Sub)", property $ prop_set_get_socket_option Sub) - , ("set;get socket option (XPub)", property $ prop_set_get_socket_option XPub) - , ("set;get socket option (XSub)", property $ prop_set_get_socket_option XSub) - , ("set;get socket option (Req)", property $ prop_set_get_socket_option Req) - , ("set;get socket option (Rep)", property $ prop_set_get_socket_option Rep) - , ("set;get socket option (Dealer)", property $ prop_set_get_socket_option Dealer) - , ("set;get socket option (Router)", property $ prop_set_get_socket_option Router) - , ("set;get socket option (Pull)", property $ prop_set_get_socket_option Pull) - , ("set;get socket option (Push)", property $ prop_set_get_socket_option Push) - , ("(un-)subscribe", property $ prop_subscribe Sub) - ] ++ - [ ("connect disconnect ", property $ prop_connect_disconnect x) | - x <- [ (AnySocket Rep, AnySocket Req) - , (AnySocket Router, AnySocket Req) - , (AnySocket Pull, AnySocket Push)]] - ) - - quickBatch' ("0MQ Messages" - , [ ("msg send == msg received (Req/Rep)", property $ prop_send_receive Req Rep) - , ("msg send == msg received (Push/Pull)", property $ prop_send_receive Push Pull) - , ("msg send == msg received (Pair/Pair)", property $ prop_send_receive Pair Pair) +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as CB +import qualified Test.QuickCheck.Monadic as QM - -- , ("publish/subscribe", property $ prop_pub_sub Pub Sub) - -- (disabled due to LIBZMQ-270 [https://zeromq.jira.com/browse/LIBZMQ-270]) - ]) +tests :: TestTree +tests = testGroup "0MQ Socket Properties" + [ testProperty "get socket option (Pair)" (prop_get_socket_option Pair) + , testProperty "get socket option (Pub)" (prop_get_socket_option Pub) + , testProperty "get socket option (Sub)" (prop_get_socket_option Sub) + , testProperty "get socket option (XPub)" (prop_get_socket_option XPub) + , testProperty "get socket option (XSub)" (prop_get_socket_option XSub) + , testProperty "get socket option (Req)" (prop_get_socket_option Req) + , testProperty "get socket option (Rep)" (prop_get_socket_option Rep) + , testProperty "get socket option (Dealer)" (prop_get_socket_option Dealer) + , testProperty "get socket option (Router)" (prop_get_socket_option Router) + , testProperty "get socket option (Pull)" (prop_get_socket_option Pull) + , testProperty "get socket option (Push)" (prop_get_socket_option Push) + , testProperty "set;get socket option (Pair)" (prop_set_get_socket_option Pair) + , testProperty "set;get socket option (Pub)" (prop_set_get_socket_option Pub) + , testProperty "set;get socket option (Sub)" (prop_set_get_socket_option Sub) + , testProperty "set;get socket option (XPub)" (prop_set_get_socket_option XPub) + , testProperty "set;get socket option (XSub)" (prop_set_get_socket_option XSub) + , testProperty "set;get socket option (Req)" (prop_set_get_socket_option Req) + , testProperty "set;get socket option (Rep)" (prop_set_get_socket_option Rep) + , testProperty "set;get socket option (Dealer)" (prop_set_get_socket_option Dealer) + , testProperty "set;get socket option (Router)" (prop_set_get_socket_option Router) + , testProperty "set;get socket option (Pull)" (prop_set_get_socket_option Pull) + , testProperty "set;get socket option (Push)" (prop_set_get_socket_option Push) + , testProperty "(un-)subscribe" (prop_subscribe Sub) + , testGroup "connect disconnect" + [ testProperty "" (prop_connect_disconnect x) + | x <- [ (AnySocket Rep, AnySocket Req) + , (AnySocket Router, AnySocket Req) + , (AnySocket Pull, AnySocket Push) + ] + ] + , testGroup "0MQ Messages" + [ testProperty "msg send == msg received (Req/Rep)" (prop_send_receive Req Rep) + , testProperty "msg send == msg received (Push/Pull)" (prop_send_receive Push Pull) + , testProperty "msg send == msg received (Pair/Pair)" (prop_send_receive Pair Pair) + -- , testProperty "publish/subscribe" (prop_pub_sub Pub Sub) + -- (disabled due to LIBZMQ-270 [https://zeromq.jira.com/browse/LIBZMQ-270]) + ] + ] prop_get_socket_option :: SocketType t => t -> GetOpt -> Property prop_get_socket_option t opt = monadicIO $ run $ do @@ -94,7 +96,7 @@ ReceiveTimeout val -> (ieq (rvalue val)) <$> (setReceiveTimeout val s >> receiveTimeout s) SendHighWM val -> (ieq (rvalue val)) <$> (setSendHighWM val s >> sendHighWM s) SendTimeout val -> (ieq (rvalue val)) <$> (setSendTimeout val s >> sendTimeout s) - assert r + QM.assert r where ieq :: (Integral i, Integral k) => i -> k -> Bool ieq i k = (fromIntegral i :: Int) == (fromIntegral k :: Int) @@ -116,7 +118,7 @@ connect sender "inproc://endpoint" send sender [] msg liftIO $ wait x - assert (msg == msg') + QM.assert (msg == msg') prop_pub_sub :: (SocketType a, Subscriber b, SocketType b, Sender a, Receiver b) => a -> b -> ByteString -> Property prop_pub_sub a b msg = monadicIO $ do @@ -128,7 +130,7 @@ connect pub "inproc://endpoint" send pub [] msg receive sub - assert (msg == msg') + QM.assert (msg == msg') prop_connect_disconnect :: (AnySocket, AnySocket) -> Property diff --git a/tests/Test/Tools.hs b/tests/Test/Tools.hs deleted file mode 100644 --- a/tests/Test/Tools.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Test.Tools (quickBatch', checkBatch') where - -import Control.Monad -import System.Console.ANSI -import System.Exit -import Test.QuickCheck -import Test.QuickCheck.Checkers -import qualified Control.Exception as E - -quickBatch' :: TestBatch -> IO () -quickBatch' = checkBatch' (stdArgs { maxSuccess = 500 }) - -checkBatch' :: Args -> TestBatch -> IO () -checkBatch' args (name, tsts) = do - writeLn Cyan name - forM_ tsts $ \(s, p) -> do - write White (" " ++ s ++ ": ") - r <- quickCheckWithResult (args { chatty = False}) p - `E.catch` - ((\e -> write Red (show e) >> exitFailure) :: E.SomeException -> IO a) - case r of - Success _ _ m -> write Green m - GaveUp _ _ m -> write Magenta m >> exitFailure - Failure _ _ _ _ _ _ _ m -> write Red m >> exitFailure - NoExpectedFailure _ _ m -> write Red m >> exitFailure - -write, writeLn :: Color -> String -> IO () -write c = withColour c . putStr -writeLn c = withColour c . putStrLn - -withColour :: Color -> IO () -> IO () -withColour c a = do - setSGR [Reset, SetColor Foreground Vivid c] - a - setSGR [Reset] diff --git a/tests/tests.hs b/tests/tests.hs --- a/tests/tests.hs +++ b/tests/tests.hs @@ -1,5 +1,7 @@ +import Test.Tasty + import qualified System.ZMQ4.Test.Properties as Properties main :: IO () -main = Properties.tests +main = defaultMain Properties.tests diff --git a/zeromq4-haskell.cabal b/zeromq4-haskell.cabal --- a/zeromq4-haskell.cabal +++ b/zeromq4-haskell.cabal @@ -1,5 +1,5 @@ name: zeromq4-haskell -version: 0.3.2 +version: 0.4 synopsis: Bindings to ZeroMQ 4.x category: System, FFI license: MIT @@ -56,7 +56,7 @@ , async == 2.0.* , bytestring , containers - , exceptions == 0.3.* + , exceptions == 0.4.* , semigroups >= 0.8 , transformers >= 0.3 @@ -72,16 +72,12 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: tests.hs - other-modules: Test.Tools - ghc-options: -Wall -threaded -rtsopts + ghc-options: -Wall -threaded build-depends: zeromq4-haskell - , ansi-terminal >= 0.6 - , async == 2.0.* - , base >= 3 && < 5 + , async == 2.0.* + , base >= 3 && < 5 , bytestring - , checkers >= 0.3 - , containers - , MonadCatchIO-transformers - , QuickCheck >= 2.6 - , transformers + , QuickCheck >= 2.6 + , tasty >= 0.8 + , tasty-quickcheck >= 0.8