tdd-util (empty) → 0.1.0.1
raw patch · 9 files changed
+579/−0 lines, 9 filesdep +HUnitdep +MonadCatchIO-transformersdep +QuickChecksetup-changed
Dependencies added: HUnit, MonadCatchIO-transformers, QuickCheck, base, lens, parallel-io, process, random, tagged, test-framework, test-framework-hunit, test-framework-quickcheck2, time, transformers
Files
- LICENSE +28/−0
- Setup.hs +7/−0
- src/Test/Util.hs +183/−0
- src/Test/Util/Framework.hs +89/−0
- tdd-util.cabal +80/−0
- testsrc/Main.hs +9/−0
- testsrc/Test/Test/Util.hs +158/−0
- testsrc/Test/Test/Util/Framework.hs +11/−0
- testsrc/Tests.hs +14/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ src/Test/Util.hs view
@@ -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
+ src/Test/Util/Framework.hs view
@@ -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
+ tdd-util.cabal view
@@ -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 <ByronJohnsonFP@gmail.com>+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
+ testsrc/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Test.Util.Framework++import Tests++main :: IO ()+main = do+ defaultMain tests
+ testsrc/Test/Test/Util.hs view
@@ -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 "<IO *>"++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
+ testsrc/Test/Test/Util/Framework.hs view
@@ -0,0 +1,11 @@+module Test.Test.Util.Framework+ ( tests+ ) where++import Test.Util.Framework++-- Nothing to test.+tests :: [TTest]+tests =+ [+ ]
+ testsrc/Tests.hs view
@@ -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+ ]