module Test.Util
(
isExceptionThrown
, assertThrown
, assertNotThrown
, timeMicroseconds
, timeoutMicroseconds
, assertMicroseconds
, timeoutProcessMicroseconds
, assertProcessMicroseconds
, TestUtilException(..)
, testUtilExceptionToException
, testUtilExceptionFromException
, TimeoutOverflow(..), timeoutOverflow_message, timeoutOverflow_microseconds, timeoutOverflow_inputBound
, TimeLimitExceeded(..), timelimitExceeded_message, timelimitExceeded_callerName, timelimitExceeded_microseconds
) where
import Control.Applicative
import Control.Exception hiding (catch)
import Control.Monad.CatchIO as M
import Control.Monad.IO.Class
import Control.Lens.TH
import Data.Dynamic
import Data.Maybe
import Data.Proxy
import Data.Time.Clock
import System.Exit
import System.Process
import System.Timeout (timeout)
import Text.Printf
import Test.Util.Framework
isExceptionThrown :: (Functor m, MonadCatchIO m, Exception e) => m a -> m (Either e a)
isExceptionThrown m = do
(Right <$> m) `M.catch` (return . Left)
assertThrown :: (Functor m, MonadCatchIO m, Exception e, Show e) => Maybe String -> Proxy e -> m () -> m ()
assertThrown ms ep m = do
either (\e -> flip const (e `asProxyTypeOf` ep) $ return ()) (const . liftIO $ assertString s) =<< isExceptionThrown m
where s = fromMaybe "exception NOT thrown" ms
assertNotThrown :: (Functor m, MonadCatchIO m, Exception e, Show e) => Maybe (e -> String) -> m () -> m ()
assertNotThrown msf m = do
either (liftIO . assertString . sf) (const $ return ()) =<< isExceptionThrown m
where sf = fromMaybe (\e -> printf "exception thrown: %s" (show e)) msf
timeMicroseconds :: (Monad m, MonadIO m) => m a -> m (a, Integer)
timeMicroseconds m = do
begin <- liftIO $ getCurrentTime
a <- m
end <- liftIO $ getCurrentTime
let nomDiffTime :: NominalDiffTime
nomDiffTime = diffUTCTime end begin
microsecondsDiff :: Integer
microsecondsDiff = round $ nomDiffTime * 1000000
return (a, microsecondsDiff)
timeoutMicroseconds :: Integer -> IO a -> IO (Maybe a)
timeoutMicroseconds us m
| us <= (fromIntegral (maxBound :: Int)) =
timeout (fromIntegral us) m
| otherwise =
throwIO $ TimeoutOverflow Nothing us (fromIntegral (maxBound :: Int))
assertMicroseconds :: Integer -> IO a -> IO a
assertMicroseconds us m = do
maybe (throwIO $ TimeLimitExceeded Nothing "assertMicroseconds" us) return =<< timeoutMicroseconds us m
timeoutProcessMicroseconds :: Integer -> ProcessHandle -> IO (Maybe ExitCode)
timeoutProcessMicroseconds us ph = do
(maybe (terminateProcess ph >> return Nothing) (return . Just) =<<) . timeoutMicroseconds us $ do
waitForProcess ph
assertProcessMicroseconds :: Integer -> ProcessHandle -> IO ()
assertProcessMicroseconds us ph = do
maybe (throwIO $ TimeLimitExceeded Nothing "assertProcessMicroseconds" us) (const $ return ()) =<< timeoutProcessMicroseconds us ph
data TestUtilException where
TestUtilException :: (Exception e) => e -> TestUtilException
deriving (Typeable)
instance Show TestUtilException where
show (TestUtilException e) = show e
instance Exception TestUtilException where
testUtilExceptionToException :: Exception e => e -> SomeException
testUtilExceptionToException = toException . TestUtilException
testUtilExceptionFromException :: Exception e => SomeException -> Maybe e
testUtilExceptionFromException x = do
(TestUtilException a) <- fromException x
cast a
data TimeoutOverflow =
TimeoutOverflow
{ _timeoutOverflow_message :: Maybe String
, _timeoutOverflow_microseconds :: Integer
, _timeoutOverflow_inputBound :: Integer
}
deriving (Typeable, Show, Eq)
instance Exception TimeoutOverflow where
toException = testUtilExceptionToException
fromException = testUtilExceptionFromException
data TimeLimitExceeded =
TimeLimitExceeded
{ _timelimitExceeded_message :: Maybe String
, _timelimitExceeded_callerName :: String
, _timelimitExceeded_microseconds :: Integer
}
deriving (Typeable, Show, Eq)
instance Exception TimeLimitExceeded where
toException = testUtilExceptionToException
fromException = testUtilExceptionFromException
makeLenses ''TimeoutOverflow
makeLenses ''TimeLimitExceeded