diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2012, Byron James Johnson +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell +module Main where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/src/Test/Util.hs b/src/Test/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Util.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE GADTs, TemplateHaskell, DeriveDataTypeable #-} + +-- | A module for various useful functions for TDD missing in other libraries. +module Test.Util + ( + -- * Throwing and catching exceptions + isExceptionThrown + , assertThrown + , assertNotThrown + + -- * Concurrent TDD (TODO: provide a means of testing a monadic property with many threads) + + -- * Process timing + , timeMicroseconds + , timeoutMicroseconds + , assertMicroseconds + , timeoutProcessMicroseconds + , assertProcessMicroseconds + + -- * Exceptions + , TestUtilException(..) + , testUtilExceptionToException + , testUtilExceptionFromException + , TimeoutOverflow(..), timeoutOverflow_message, timeoutOverflow_microseconds, timeoutOverflow_inputBound + , TimeLimitExceeded(..), timelimitExceeded_message, timelimitExceeded_callerName, timelimitExceeded_microseconds + ) where + +import Control.Applicative +--import Control.Concurrent.ParallelIO.Local +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 + +--- Throwing and catching exceptions --- + +-- | Determine whether an exception was caught, and return it if so. +isExceptionThrown :: (Functor m, MonadCatchIO m, Exception e) => m a -> m (Either e a) +isExceptionThrown m = do + (Right <$> m) `catch` (return . Left) + +-- | Assert that an exception is thrown. +-- +-- When an exception is not thrown, the input 'String', or otherwise a +-- default string, is output. +-- +-- For more control, see the more fundamental 'isExceptionThrown'. +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 + +-- | Assert that an exception is not thrown. +-- +-- When an exception is thrown, the input function, or a default one, is +-- given the exception and the resulting string is output. +-- +-- For more control, see the more fundamental 'isExceptionThrown'. +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 + + +--- Concurrent TDD --- + + +--- Process timing --- + +-- | Time a computation. +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) + +-- | Run a computation within an approximate time limit. +-- +-- This is currently a wrapper for 'System.Timeout.timeout' that checks for +-- overflows. +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)) + +-- | Assert that a computation runs within an approximate time limit. +-- +-- If the computation does not finish within the given time limit, a +-- 'TimeLimitExceeded' exception is thrown. +-- +-- For more control, see the more fundamental 'timeoutMicroseconds' function. +assertMicroseconds :: Integer -> IO a -> IO a +assertMicroseconds us m = do + maybe (throwIO $ TimeLimitExceeded Nothing "assertMicroseconds" us) return =<< timeoutMicroseconds us m + +-- | Apply an approximate time limit, from the current time, to a process by +-- its handle. +-- +-- If the process finishes approximately within the given time limit, 'Just' +-- its exit code is returned. Otherwise, it is killed and 'Nothing' is +-- returned. +-- +-- This function requires a threaded runtime system to work properly. +timeoutProcessMicroseconds :: Integer -> ProcessHandle -> IO (Maybe ExitCode) +timeoutProcessMicroseconds us ph = do + (maybe (terminateProcess ph >> return Nothing) (return . Just) =<<) . timeoutMicroseconds us $ do + waitForProcess ph + +-- | Assert that a process finishes within an approximate time limit. +-- +-- If the computation does not finish within the given time limit, a +-- 'TimeLimitExceeded' exception is thrown. +-- +-- For more control, see the more fundamental 'timeoutProcessMicroseconds' function. +assertProcessMicroseconds :: Integer -> ProcessHandle -> IO () +assertProcessMicroseconds us ph = do + maybe (throwIO $ TimeLimitExceeded Nothing "assertProcessMicroseconds" us) (const $ return ()) =<< timeoutProcessMicroseconds us ph + +--- Exceptions --- + +-- | A class of exceptions for "Tests.Util". +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 + +-- | 'timeoutMicrosoconds' was invoked with an integer that would cause the +-- input given to 'timeout' to overflow. +data TimeoutOverflow = + TimeoutOverflow + { _timeoutOverflow_message :: Maybe String -- ^ Optional error message. + , _timeoutOverflow_microseconds :: Integer -- ^ Input given to 'timeoutMicroseconds'. + , _timeoutOverflow_inputBound :: Integer -- ^ Maximum bound of 'Int' as an 'Integer'. + } + deriving (Typeable, Show, Eq) + +instance Exception TimeoutOverflow where + toException = testUtilExceptionToException + fromException = testUtilExceptionFromException + +data TimeLimitExceeded = + TimeLimitExceeded + { _timelimitExceeded_message :: Maybe String -- ^ Optional error message. + , _timelimitExceeded_callerName :: String -- ^ Name of the function that directly threw the exception ('assertMicroseconds', etc.) + , _timelimitExceeded_microseconds :: Integer -- ^ The timelimit. + } + deriving (Typeable, Show, Eq) + +instance Exception TimeLimitExceeded where + toException = testUtilExceptionToException + fromException = testUtilExceptionFromException + +makeLenses ''TimeoutOverflow +makeLenses ''TimeLimitExceeded diff --git a/src/Test/Util/Framework.hs b/src/Test/Util/Framework.hs new file mode 100644 --- /dev/null +++ b/src/Test/Util/Framework.hs @@ -0,0 +1,89 @@ +-- | "Test.Util.Framework" is a super-module that re-exports other modules +-- pertaining to TDD, so that they can be imported under a single module. +-- +-- HUnit's @Test@ type is renamed to 'HTest', and test-framework's to 'TTest'. +-- The same renaming scheme, with the addition that @Q@ is prepended for +-- QuickCheck, has been applied to the following names: +-- +-- * 'Test' +-- +-- * 'assert' +-- +-- * 'State' +-- +-- * 'test' +-- +-- 'Test.QuickCheck.Property.Result' is renamed to 'SingleResult'; 'reason' +-- in this module cannot be renamed, so it is unfortunately not exported. +-- +-- Unfortunately, Haskell's design makes it inconvenient to rename classes. +-- In this module, 'Testable' is not re-exported from any module. +module Test.Util.Framework + ( module Test.HUnit + , module Test.QuickCheck + , module Test.QuickCheck.All + , module Test.QuickCheck.Arbitrary + , module Test.QuickCheck.Function + , module Test.QuickCheck.Gen + , module Test.QuickCheck.Modifiers + , module Test.QuickCheck.Monadic + , module Test.QuickCheck.Poly + , module Test.QuickCheck.Property + , module Test.QuickCheck.State + , module Test.QuickCheck.Test + , module Test.QuickCheck.Text + , module Test.Framework + , module Test.Framework.Providers.HUnit + , module Test.Framework.Providers.QuickCheck2 + + , HTest + , TTest + , qAssert + , QState + , qTest + , SingleResult + ) where + +import System.Random (StdGen) +import Test.HUnit hiding (Test, Testable, assert, State, test) +import qualified Test.HUnit +import Test.QuickCheck hiding (Testable) +import Test.QuickCheck.All +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Function +import Test.QuickCheck.Gen +import Test.QuickCheck.Modifiers +import Test.QuickCheck.Monadic hiding (assert) +import qualified Test.QuickCheck.Monadic +import Test.QuickCheck.Poly +import Test.QuickCheck.Property hiding (Result(reason)) +import qualified Test.QuickCheck.Property +import Test.QuickCheck.State hiding (State) +import qualified Test.QuickCheck.State +import Test.QuickCheck.Test hiding (test) +import qualified Test.QuickCheck.Test +import Test.QuickCheck.Text +import Test.Framework hiding (Test) +import qualified Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 + +-- | Alias for 'Test.HUnit.Test'. +type HTest = Test.HUnit.Test + +-- | Alias for 'Test.Framework.Test'. +type TTest = Test.Framework.Test + +-- | Alias for 'Test.QuickCheck.Monadic.assert'. +qAssert :: (Monad m) => Bool -> PropertyM m () +qAssert = Test.QuickCheck.Monadic.assert + +-- | Alias for 'Test.QuickCheck.State.State'. +type QState = Test.QuickCheck.State.State + +-- | Alias for 'Test.QuickCheck.Test.test'. +qTest :: QState -> (StdGen -> Int -> Prop) -> IO Result +qTest = Test.QuickCheck.Test.test + +-- | Alias for 'Test.QuickCheck.Property.Result'. +type SingleResult = Test.QuickCheck.Property.Result diff --git a/tdd-util.cabal b/tdd-util.cabal new file mode 100644 --- /dev/null +++ b/tdd-util.cabal @@ -0,0 +1,80 @@ +name: tdd-util +version: 0.1.0.1 +cabal-version: >= 1.10 +build-type: Simple +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) 2012 Byron James Johnson +author: Byron James Johnson +maintainer: Byron James Johnson +synopsis: Utilities for TDD with test-framework, HUnit, and QuickCheck +description: + This library provides utility functions for TDD in the manner of "MissingH". + . + This package contains a test suite that is an excellent example of using + this library and may be cargo culted to save time starting TDD on a new + project. +category: Testing +tested-with: GHC == 7.6.1 + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall + default-extensions: + GADTs + ,TemplateHaskell + ,DeriveDataTypeable + build-depends: + base >= 4 && < 6 + ,lens + ,transformers + ,tagged + ,random + ,process + ,time + ,parallel-io + ,MonadCatchIO-transformers + ,HUnit + ,QuickCheck >= 2 && < 3 + ,test-framework + ,test-framework-hunit + ,test-framework-quickcheck2 + exposed-modules: + Test.Util + ,Test.Util.Framework + +test-suite tdd-util-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: testsrc, src + ghc-options: -Wall -threaded + main-is: Main.hs + default-extensions: + GADTs + ,TemplateHaskell + ,DeriveDataTypeable + build-depends: + base >= 4 && < 6 + ,lens + ,transformers + ,tagged + ,random + ,process + ,time + ,parallel-io + ,MonadCatchIO-transformers + ,HUnit + ,QuickCheck >= 2 && < 3 + ,test-framework + ,test-framework-hunit + ,test-framework-quickcheck2 + other-modules: + Tests + ,Test.Test.Util + ,Test.Test.Util.Framework + +source-repository head + type: git + location: git://github.com/bairyn/tdd-util.git + tag: 0.1.0.1 diff --git a/testsrc/Main.hs b/testsrc/Main.hs new file mode 100644 --- /dev/null +++ b/testsrc/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.Util.Framework + +import Tests + +main :: IO () +main = do + defaultMain tests diff --git a/testsrc/Test/Test/Util.hs b/testsrc/Test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/testsrc/Test/Test/Util.hs @@ -0,0 +1,158 @@ +module Test.Test.Util + ( tests + ) where + +import Control.Applicative +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.Proxy +import System.Process +import Text.Printf + +import Test.Util +import Test.Util.Framework + +newtype ShowableIO a = ShowableIO (IO a) + +instance Show (ShowableIO a) where + show = const "" + +tests :: [TTest] +tests = + [ testGroup "Throwing and catching exceptions - isExceptionThrown" $ + [ testCase "throwing an exception" $ do + thrown <- isExceptionThrown $ do + throwIO $ AssertionFailed "assertion failed" + when (either (\e -> flip const (e :: AssertionFailed) $ False) (const True) $ thrown) $ do + assertString "exception NOT thrown" + , testCase "not throwing an exception" $ do + thrown <- isExceptionThrown $ do + return () + when (either (\e -> flip const (e :: AssertionFailed) $ True) (const False) $ thrown) $ do + assertString "exception thrown" + ] + , testGroup "Throwing and catching exceptions - assert*Thrown" $ + [ testCase "throwing an exception" $ do + assertThrown Nothing (Proxy :: Proxy AssertionFailed) $ do + throwIO $ AssertionFailed "assertion failed" + , testCase "not throwing an exception" $ do + assertNotThrown (Nothing :: Maybe (AssertionFailed -> String)) $ do + return () + ] + , testGroup "isExceptionThrown -> assert*Thrown" $ + [ testProperty "Applying appropriate assert*Thrown given result of isExceptionThrown" . monadicIO $ + forAllM (elements . map ShowableIO $ [throwIO $ AssertionFailed "assertion failed", return ()]) $ \ ~(ShowableIO m) -> do + run $ do + either (\e -> flip const (e :: AssertionFailed) $ + assertThrown Nothing (let p = Proxy in flip const (e `asProxyTypeOf` p) $ (p :: Proxy AssertionFailed)) m) + (\ ~() -> assertNotThrown (Nothing :: Maybe (AssertionFailed -> String)) m) + =<< (isExceptionThrown m :: IO (Either AssertionFailed ())) + ] + -- TODO: (See annotation.) + , testGroup "Timed tests (TODO: Once a means of testing a monadic property with many threads is implemented, increase maxDelayTime from 30ms to 600ms; tests may not be as reliable until then.)" $ + [ testGroup "timeMicroseconds" $ + let time process m = do + forAllM (choose (0, maxDelayTime)) $ \actualUs -> do + us <- run . (snd <$>) . timeMicroseconds $ m actualUs + qAssert $ (abs $ us - actualUs) <= if process then processCushion else cushion + in [ testProperty "timeMicroseconds is accurate for random sleep times within 10ms" . monadicIO $ + time True $ \actualUs -> do + ph <- createSleepProcess (printf "%f" ((fromIntegral actualUs :: Double) / 1000000)) + void $ waitForProcess ph + , testProperty "timeMicroseconds is accurate for random delay times by timeout within 10ms" . monadicIO $ + time False $ \actualUs -> do + threadDelay (fromIntegral actualUs) + ] + , testGroup "timeoutMicroseconds behaves like timeout and throws exceptions appropriately" $ + [ testCase "timeoutMicroseconds overflow" $ + assertThrown Nothing (Proxy :: Proxy TimeoutOverflow) $ do + let us :: Integer + us = (fromIntegral (maxBound :: Int)) + 1 + (fromMaybe () <$>) . timeoutMicroseconds us $ return () + , testCase "timeoutMicroseconds non-overflow" $ + assertNotThrown (Nothing :: Maybe (TimeoutOverflow -> String)) $ do + let us :: Integer + us = 2 + (fromMaybe () <$>) . timeoutMicroseconds us $ return () + , testProperty "waiting for a random amount of time from 0ms - 600ms; measured time difference is less than 10ms" . monadicIO $ + forAllM (choose (0, maxDelayTime)) $ \us -> do + actualUs <- run . (snd <$>) . timeMicroseconds $ do + void . timeoutMicroseconds us $ do + forever $ threadDelay 1 + qAssert $ (abs $ us - actualUs) <= cushion + ] + ] + -- TODO: (See annotation.) + , testGroup "assertMicroseconds (TODO: Once a means of testing a monadic property with many threads is implemented, increase maxDelayTime from 30ms to 600ms; tests may not be as reliable until then.)" $ + [ testProperty "timeoutMicroseconds -> assertMicroseconds (assert*Thrown)" . monadicIO $ + -- (us, cap); cap from us is greater than cushion + forAllM (choose (0, maxDelayTime)) $ \us -> forAllM (choose (0, maxDelayTime) `suchThat` \cap -> abs (cap - us) > cushion) $ \cap -> do + run $ do + let sleepM = threadDelay (fromIntegral us) + killed <- maybe True (const False) <$> timeoutMicroseconds cap sleepM + if killed + then do + assertThrown Nothing (Proxy :: Proxy TimeLimitExceeded) $ do + assertMicroseconds cap sleepM + else do + assertNotThrown (Nothing :: Maybe (TimeLimitExceeded -> String)) $ do + assertMicroseconds cap sleepM + ] + , testGroup "timeoutProcessMicroseconds behaves like timeoutMicroseconds and throws exceptions appropriately" $ + [ testCase "timeoutProcessMicroseconds overflow" $ + assertThrown Nothing (Proxy :: Proxy TimeoutOverflow) $ do + let us :: Integer + us = (fromIntegral (maxBound :: Int)) + 1 + (fromMaybe () <$>) . timeoutMicroseconds us $ return () + , testCase "timeoutProcessMicroseconds non-overflow" $ + assertNotThrown (Nothing :: Maybe (TimeoutOverflow -> String)) $ do + let us :: Integer + us = 2 + (fromMaybe () <$>) . timeoutMicroseconds us $ return () + , testProperty "random sleep times and timeouts; return value is appropriate (NB: requires -threaded to work properly)" . monadicIO $ + forAllM (choose (0, maxDelayTime)) $ \us -> forAllM (choose (0, maxDelayTime) `suchThat` \cap -> abs (cap - us) > cushion) $ \cap -> do + killed <- run $ do + ph <- createSleepProcess (printf "%f" ((fromIntegral us :: Double) / 1000000)) + maybe True (const False) <$> timeoutProcessMicroseconds cap ph + qAssert $ killed == (cap < us) + ] + -- TODO: (See annotation.) + , testGroup "assertProcessMicroseconds (TODO: Once a means of testing a monadic property with many threads is implemented, increase maxDelayTime from 30ms to 600ms; tests may not be as reliable until then.)" $ + [ testProperty "timeoutProcessMicroseconds -> assertProcessMicroseconds (assert*Thrown)" . monadicIO $ + -- (us, cap); cap from us is greater than cushion + forAllM (choose (0, maxDelayTime)) $ \us -> forAllM (choose (0, maxDelayTime) `suchThat` \cap -> abs (cap - us) > cushion) $ \cap -> do + run $ do + let sleepM = createSleepProcess (printf "%f" ((fromIntegral us :: Double) / 1000000)) + killed <- maybe True (const False) <$> (timeoutProcessMicroseconds cap =<< sleepM) + if killed + then do + assertThrown Nothing (Proxy :: Proxy TimeLimitExceeded) $ do + assertProcessMicroseconds cap =<< sleepM + else do + assertNotThrown (Nothing :: Maybe (TimeLimitExceeded -> String)) $ do + assertProcessMicroseconds cap =<< sleepM + ] + ] + where cushion :: Integer + cushion = 20000 + -- Cushion with process creation; creating process can take time. + processCushion :: Integer + processCushion = 200000 + maxDelayTime :: Integer + --maxDelayTime = 600000 + maxDelayTime = 40000 + createSleepProcess :: String -> IO ProcessHandle + createSleepProcess arg1 = do + ((Just _), (Just _), (Nothing), ph) <- createProcess $ CreateProcess + { cmdspec = RawCommand "sleep" [arg1] + , cwd = Nothing + , env = Nothing + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = Inherit + , close_fds = True + , create_group = False + } + return ph diff --git a/testsrc/Test/Test/Util/Framework.hs b/testsrc/Test/Test/Util/Framework.hs new file mode 100644 --- /dev/null +++ b/testsrc/Test/Test/Util/Framework.hs @@ -0,0 +1,11 @@ +module Test.Test.Util.Framework + ( tests + ) where + +import Test.Util.Framework + +-- Nothing to test. +tests :: [TTest] +tests = + [ + ] diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs new file mode 100644 --- /dev/null +++ b/testsrc/Tests.hs @@ -0,0 +1,14 @@ +module Tests + ( tests + ) where + +import Test.Util.Framework + +import qualified Test.Test.Util +import qualified Test.Test.Util.Framework + +tests :: [TTest] +tests = + [ testGroup "Test.Test.Util.tests" $ Test.Test.Util.tests + , testGroup "Test.Test.Util.Framework.tests" $ Test.Test.Util.Framework.tests + ]