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
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) `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