diff --git a/AC-MiniTest.cabal b/AC-MiniTest.cabal
new file mode 100644
--- /dev/null
+++ b/AC-MiniTest.cabal
@@ -0,0 +1,37 @@
+Cabal-version: >=1.2
+Name: AC-MiniTest
+Version: 1.1.1
+Synopsis: A simple test framework.
+Description:
+
+ This is a simple testing library. It focuses mainly on making it
+ easy to run large test suites and collect the results together.
+ .
+ This package is currently fairly experimental. The API may change
+ in the near future. Hopefully this release should be relatively
+ bug-free, however.
+ .
+ Changes:
+ .
+ * Initial release.
+
+License: BSD3
+License-file: License.txt
+Author: Andrew Coppin
+Maintainer: MathematicalOrchid@hotmail.com
+Category: Testing
+Build-type: Simple
+
+Library
+ Exposed-modules:
+ Test.AC.Label
+ Test.AC.Test
+ Test.AC.Class.Eq
+ Test.AC.Class.Ord
+ Test.AC.Class.Functor
+ Test.AC.Class.Monad
+ Other-modules:
+ Test.AC.Private
+ Build-depends:
+ base >= 4.2 && < 5,
+ transformers >= 0.2
diff --git a/License.txt b/License.txt
new file mode 100644
--- /dev/null
+++ b/License.txt
@@ -0,0 +1,30 @@
+Copyright (c)2012, Andrew Coppin
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * 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.
+
+ * Neither the name of Andrew Coppin nor the names of other
+ 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,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Test/AC/Class/Eq.hs b/Test/AC/Class/Eq.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Class/Eq.hs
@@ -0,0 +1,69 @@
+{- |
+ Properties for testing that instances of the 'Eq' class perform
+ correctly.
+
+ 'p_reflexive', 'p_symmetric' and 'p_transitive' check the basic
+ properties of an equity relation. In other words, they test the
+ '==' method. 'p_not_equal' checks for the extraordinarily unlikely
+ case of '==' and '/=' not agreeing on equity. (The default
+ implementation of '/=' automatically guarantees that this test
+ will pass, and that's what most people presumably use.)
+-}
+
+module Test.AC.Class.Eq where
+
+import Test.AC.Test
+
+-- | Check that @x == x@.
+p_reflexive :: (Show x, Eq x) => x -> Test
+p_reflexive x =
+ title "x == x" $
+ x ?= x
+
+-- | Check that if @x == y@ then @y == x@ as well.
+p_symmetric :: (Show x, Eq x) => x -> x -> Test
+p_symmetric x y =
+ title "if x == y then y == x" $
+ argument "x" x $
+ argument "y" y $
+ temporary "x == y" (x == y) $
+ (y == x) ?= (x == y)
+
+-- | Check that if @x == y@ and @y == z@ then @x == z@.
+p_transitive :: (Show x, Eq x) => x -> x -> x -> Test
+p_transitive x y z =
+ title "if x == y and y == z then x == z" $
+ argument "x" x $
+ argument "y" y $
+ argument "z" z $
+ temporary "x == y" (x == y) $
+ temporary "y == z" (y == z) $
+ if (x /= y) && (y /= z)
+ then inapplicable
+ else (x == z) ?= ((x == y) && (y == z))
+
+-- | Check that @x /= y@ is the same as @not (x == y)@.
+p_not_equal :: (Show x, Eq x) => x -> x -> Test
+p_not_equal x y =
+ title "x /= y is not(x == y)" $
+ argument "x" x $
+ argument "y" y $
+ temporary "x == y" (x == y) $
+ (x /= y) ?= not (x == y)
+
+{- |
+ Given a list of /distinct/ values, perform all applicable tests
+ on all possible combinations of inputs. (If the inputs are not
+ distinct, some redundant tests are performed.)
+-}
+p_Eq :: (Show x, Eq x) => [x] -> Test
+p_Eq xs =
+ title "p_Eq" $
+ argument "xs" xs $
+ tests
+ [
+ title "p_reflexive" $ tests [ p_reflexive x | x <- xs ],
+ title "p_symmetric" $ tests [ p_symmetric x y | x <- xs, y <- xs ],
+ title "p_transitive" $ tests [ p_transitive x y z | x <- xs, y <- xs, z <- xs ],
+ title "p_not_equal" $ tests [ p_not_equal x y | x <- xs, y <- xs ]
+ ]
diff --git a/Test/AC/Class/Functor.hs b/Test/AC/Class/Functor.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Class/Functor.hs
@@ -0,0 +1,87 @@
+{- |
+ Properties for testing that instances of the 'Functor' class
+ perform correctly.
+
+ This testing requires an 'Eq' instance, which not all 'Functor's
+ actually have. It also requires a 'Show' instance, which is also
+ uncommon. The 'Label1' wrapper may be useful in dealing with the
+ 'Show' requirement.
+
+ Tests are supplied both in regular \"unlabelled\" form, and also
+ in a special \"labelled\" form, where function objects have
+ 'Label's attached to them. Because of this, the function used for
+ each test can be recorded in the test log, which can be quite
+ helpful.
+-}
+
+module Test.AC.Class.Functor where
+
+import Test.AC.Test
+import Test.AC.Label
+
+-- * Unlabelled tests
+
+-- | Check that @'fmap' 'id' '==' 'id'@.
+p_map_id :: (Functor f, Eq (f x), Show (f x)) => f x -> Test
+p_map_id fx =
+ title "fmap id == id" $
+ argument "fx" fx $
+ fmap id fx ?= fx
+
+-- | Check that @'fmap' (f '.' g) '==' 'fmap' 'f' '.' 'fmap' g@.
+p_map_compose :: (Functor f, Eq (f z), Show (f x), Show (f y), Show (f z)) => f x -> (x -> y) -> (y -> z) -> Test
+p_map_compose fx g f =
+ title "fmap (f . g) == fmap f . fmap g" $
+ argument "fx" fx $
+ temporary "fmap g fx" (fmap g fx) $
+ temporary "fmap f (fmap g fx)" (fmap f (fmap g fx)) $
+ fmap (f . g) fx ?= fmap f (fmap g fx)
+
+{- |
+ Given a list of /distinct/ 'Functor' values and functions, perform
+ all tests on all combinations of inputs. (If the inputs are not
+ distinct, some redundant tests will be performed.)
+
+ The argument types are somewhat constrained to keep the type
+ signature reasonably simple.
+-}
+p_Functor :: (Functor f, Eq (f x), Show (f x)) => [f x] -> [x -> x] -> Test
+p_Functor fxs fs =
+ title "p_Functor" $
+ argument "fxs" fxs $
+ tests
+ [
+ title "p_map_id" $ tests [ p_map_id fx | fx <- fxs ],
+ title "p_map_compose" $ tests [ p_map_compose fx f2 f1 | fx <- fxs, f1 <- fs, f2 <- fs ]
+ ]
+
+-- * Labelled tests
+
+-- | Check that @'fmap' (f '.' g) '==' 'fmap' 'f' '.' 'fmap' g@.
+p_map_compose_L :: (Functor f, Eq (f z), Show (f x), Show (f y), Show (f z)) => f x -> Label (x -> y) -> Label (y -> z) -> Test
+p_map_compose_L fx (Label lg g) (Label lf f) =
+ title "fmap (f . g) == fmap f . fmap g" $
+ argument "fx" fx $
+ argument_ "f" lf $
+ argument_ "g" lg $
+ temporary "fmap g fx" (fmap g fx) $
+ temporary "fmap f (fmap g fx)" (fmap f (fmap g fx)) $
+ fmap (f . g) fx ?= fmap f (fmap g fx)
+
+{- |
+ Given a list of /distinct/ 'Functor' values and functions, perform
+ all tests on all combinations of inputs. (If the inputs are not
+ distinct, some redundant tests will be performed.)
+
+ The argument types are somewhat constrained to keep the function's
+ type signature reasonably simple.
+-}
+p_Functor_L :: (Functor f, Eq (f x), Show (f x)) => [f x] -> [Label (x -> x)] -> Test
+p_Functor_L fxs fs =
+ title "p_Functor_L" $
+ argument "fxs" fxs $
+ tests
+ [
+ title "p_map_id" $ tests [ p_map_id fx | fx <- fxs ],
+ title "p_map_compose_L" $ tests [ p_map_compose_L fx f2 f1 | fx <- fxs, f1 <- fs, f2 <- fs ]
+ ]
diff --git a/Test/AC/Class/Monad.hs b/Test/AC/Class/Monad.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Class/Monad.hs
@@ -0,0 +1,131 @@
+{- |
+ Properties for testing that instances of the 'Monad' class
+ perform correctly.
+
+ This testing requires an 'Eq' instance, which not all 'Monad's
+ actually have. It also requires a 'Show' instance, which is also
+ uncommon. The 'Label1' wrapper may be useful in dealing with the
+ 'Show' requirement.
+
+ Tests are supplied both in regular \"unlabelled\" form, and also
+ in a special \"labelled\" form, where function objects have
+ 'Label's attached to them. Because of this, the function used for
+ each test can be recorded in the test log, which can be quite
+ helpful.
+-}
+
+module Test.AC.Class.Monad where
+
+import Test.AC.Test
+import Test.AC.Label
+
+-- * Unlabelled tests
+
+-- | Check that @return x >>= f '==' f x@.
+p_return_bind :: (Monad m, Eq (m y), Show x, Show (m x), Show (m y)) => x -> (x -> m y) -> Test
+p_return_bind x f =
+ title "return x >>= f == f x" $
+ argument "x" x $
+ temporary "return x" ((return x) `asTypeOf` (f x >> return x)) $
+ (return x >>= f) ?= (f x)
+
+-- | Check that @mx >>= return '==' mx@.
+p_bind_return :: (Monad m, Eq (m x), Show (m x)) => m x -> Test
+p_bind_return mx =
+ title "mx >>= return == mx" $
+ argument "mx" mx $
+ (mx >>= return) ?= mx
+
+{- |
+ Check that '>>=' is associative.
+
+ Approximately, @mx >>= (f >>= g) '==' (mx >>= f) >>= g@, but that
+ doesn't type-check. To be exact,
+ @mx >>= (\\ x -> f x >>= g) '==' (mx >>= f) >>= g@.
+-}
+p_bind_associative :: (Monad m, Eq (m z), Show (m x), Show (m y), Show (m z)) => m x -> (x -> m y) -> (y -> m z) -> Test
+p_bind_associative mx f g =
+ title "mx >>= (f >>= g) == (mx >>= f) >>= g" $
+ argument "mx" mx $
+ temporary "mx >>= f" (mx >>= f) $
+ (mx >>= (\ x -> f x >>= g)) ?= ((mx >>= f) >>= g)
+
+{- |
+ Given a list of /distinct/ inputs, run all applicable 'Monad'
+ tests on all combinations of inputs. (If the inputs are not
+ distinct, some redundant tests will be performed.)
+
+ The argument types have been constrainted a bit to keep the
+ function's type signature reasonably simple.
+-}
+p_Monad :: (Monad m, Eq (m x), Show x, Show (m x)) => [x] -> [x -> m x] -> [m x] -> Test
+p_Monad xs fs mxs =
+ title "p_Monad" $
+ argument "xs" xs $
+ tests
+ [
+ title "p_return_bind" $ tests [ p_return_bind x f | x <- xs, f <- fs ],
+ title "p_bind_return" $ tests [ p_bind_return mx | mx <- mxs ],
+ title "p_bind_associative" $ tests [ p_bind_associative mx f1 f2 | mx <- mxs, f1 <- fs, f2 <- fs ]
+ ]
+
+-- | Check that @fmap f mx '==' mx >>= return . f@.
+p_Functor_Monad :: (Functor m, Monad m, Eq (m y), Show (m x), Show (m y)) => m x -> (x -> y) -> Test
+p_Functor_Monad mx f =
+ title "fmap f mx == mx >>= return . f" $
+ argument "mx" mx $
+ (fmap f mx) ?= (mx >>= return . f)
+
+-- * Labelled tests
+
+-- | Check that @return x >>= f '==' f x@.
+p_return_bind_L :: (Monad m, Eq (m y), Show x, Show (m x), Show (m y)) => x -> Label (x -> m y) -> Test
+p_return_bind_L x (Label lf f) =
+ title "return x >>= f == f x" $
+ argument "x" x $
+ argument_ "f" lf $
+ temporary "return x" ((return x) `asTypeOf` (f x >> return x)) $
+ (return x >>= f) ?= (f x)
+
+{- |
+ Check that '>>=' is associative.
+
+ Approximately, @mx >>= (f >>= g) '==' (mx >>= f) >>= g@, but that
+ doesn't type-check. To be exact,
+ @mx >>= (\\ x -> f x >>= g) '==' (mx >>= f) >>= g@.
+-}
+p_bind_associative_L :: (Monad m, Eq (m z), Show (m x), Show (m y), Show (m z)) => m x -> Label (x -> m y) -> Label (y -> m z) -> Test
+p_bind_associative_L mx (Label lf f) (Label lg g) =
+ title "mx >>= (f >>= g) == (mx >>= f) >>= g" $
+ argument "mx" mx $
+ argument_ "f" lf $
+ argument_ "g" lg $
+ temporary "mx >>= f" (mx >>= f) $
+ (mx >>= (\ x -> f x >>= g)) ?= ((mx >>= f) >>= g)
+
+{- |
+ Given a list of /distinct/ inputs, run all applicable 'Monad'
+ tests on all combinations of inputs. (If the inputs are not
+ distinct, some redundant tests will be performed.)
+
+ The argument types have been constrainted a bit to keep the
+ function's type signature reasonably simple.
+-}
+p_Monad_L :: (Monad m, Eq (m x), Show x, Show (m x)) => [x] -> [Label (x -> m x)] -> [m x] -> Test
+p_Monad_L xs fs mxs =
+ title "p_Monad" $
+ argument "xs" xs $
+ tests
+ [
+ title "p_return_bind" $ tests [ p_return_bind_L x f | x <- xs, f <- fs ],
+ title "p_bind_return" $ tests [ p_bind_return mx | mx <- mxs ],
+ title "p_bind_associative" $ tests [ p_bind_associative_L mx f1 f2 | mx <- mxs, f1 <- fs, f2 <- fs ]
+ ]
+
+-- | Check that @fmap f mx '==' mx >>= return . f@.
+p_Functor_Monad_L :: (Functor m, Monad m, Eq (m y), Show (m x), Show (m y)) => m x -> Label (x -> y) -> Test
+p_Functor_Monad_L mx (Label lf f) =
+ title "fmap f mx == mx >>= return . f" $
+ argument "mx" mx $
+ argument_ "f" lf $
+ (fmap f mx) ?= (mx >>= return . f)
diff --git a/Test/AC/Class/Ord.hs b/Test/AC/Class/Ord.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Class/Ord.hs
@@ -0,0 +1,122 @@
+{- |
+ Properties for testing that instances of the 'Ord' class perform
+ correctly.
+
+ 'p_symmetric' and 'p_transitive' check the basic properties of the
+ ordering. In other words, they test the 'compare' method. 'p_equal'
+ checks that 'Ord' agrees with 'Eq' (that is, 'compare' returns 'EQ'
+ when '==' returns 'True'). The "Test.AC.Class.Eq" module already
+ checks that 'Eq' is reflexive, so if 'Ord' agrees with 'Eq' then
+ 'Ord' too is reflexive, and we don't need a seperate test for that.
+ The remaining tests (i.e., 'p_compare', 'p_min' and 'p_max') check
+ for the extraordinarily unlikely case that the various 'Ord'
+ methods do not agree with each other. (Usually they are implemented
+ in terms of each other.)
+-}
+
+module Test.AC.Class.Ord where
+
+import Test.AC.Test
+
+-- | Check that 'compare' agrees with '==' on equity.
+p_equal :: (Show x, Ord x) => x -> x -> Test
+p_equal x y =
+ title "compare agrees with (==)" $
+ argument "x" x $
+ argument "y" y $
+ temporary "x == y" (x == y) $
+ temporary "compare x y" (compare x y) $
+ if x == y
+ then compare x y ?= EQ
+ else compare x y ?/= EQ
+
+-- | Check that swapping the arguments to 'compare' works correctly.
+p_symmetric :: (Show x, Ord x) => x -> x -> Test
+p_symmetric x y =
+ title "if x < y then y > x" $
+ argument "x" x $
+ argument "y" y $
+ temporary "compare x y" (compare x y) $
+ case compare x y of
+ EQ -> compare y x ?= EQ
+ LT -> compare y x ?= GT
+ GT -> compare y x ?= LT
+
+-- | Check that if @x \< y@ and @y \< z@ then @x \< z@.
+p_transitive :: (Show x, Ord x) => x -> x -> x -> Test
+p_transitive x y z =
+ title "if x < y and y < z then x < z" $
+ argument "x" x $
+ argument "y" y $
+ argument "z" z $
+ temporary "compare x y" (compare x y) $
+ temporary "compare y z" (compare y z) $
+ case (compare x y, compare y z) of
+ (EQ, c ) -> compare x z ?= c
+ (c , EQ) -> compare x z ?= c
+ (c1, c2) -> if c1 == c2 then compare x z ?= c1 else inapplicable
+
+-- | Check that 'compare' agrees with '>', '<', etc.
+p_compare :: (Show x, Ord x) => x -> x -> Test
+p_compare x y =
+ title "compare x y agrees with (<), (>), etc." $
+ argument "x" x $
+ argument "y" y $
+ temporary "compare x y" (compare x y) $
+ let
+ (b1, b2, b3, b4) =
+ case compare x y of
+ LT -> (True , True , False, False)
+ EQ -> (False, True , False, True )
+ GT -> (False, False, True , True )
+ in
+ tests
+ [
+ title "x < y" $ (x < y) ?= b1,
+ title "x <= y" $ (x <= y) ?= b2,
+ title "x > y" $ (x > y) ?= b3,
+ title "x >= y" $ (x >= y) ?= b4
+ ]
+
+-- | Check that 'min' works correctly.
+p_min :: (Show x, Ord x) => x -> x -> Test
+p_min x y =
+ title "min x y" $
+ argument "x" x $
+ argument "y" y $
+ temporary "compare x y" (compare x y) $
+ case compare x y of
+ EQ -> tests [title "min x y == x" $ min x y ?= x, title "min x y == y" $ min x y ?= y]
+ LT -> min x y ?= x
+ GT -> min x y ?= y
+
+-- | Check that 'max' works correctly.
+p_max :: (Show x, Ord x) => x -> x -> Test
+p_max x y =
+ title "max x y" $
+ argument "x" x $
+ argument "y" y $
+ temporary "compare x y" (compare x y) $
+ case compare x y of
+ EQ -> tests [title "max x y == x" $ max x y ?= x, title "max x y == y" $ max x y ?= y]
+ LT -> max x y ?= y
+ GT -> max x y ?= x
+
+{- |
+ Given a list of /distinct/ values, perform all applicable tests
+ on all possible combinations of inputs. (If the inputs are not
+ distinct, some redundant tests are performed.)
+-}
+p_Ord :: (Show x, Ord x) => [x] -> Test
+p_Ord xs =
+ title "p_Eq" $
+ argument "xs" xs $
+ tests
+ [
+ title "p_equal" $ tests [ p_equal x y | x <- xs, y <- xs ],
+ title "p_symmetric" $ tests [ p_symmetric x y | x <- xs, y <- xs ],
+ title "p_transitive" $ tests [ p_transitive x y z | x <- xs, y <- xs, z <- xs ],
+ title "p_compare" $ tests [ p_compare x y | x <- xs, y <- xs ],
+ title "p_min" $ tests [ p_min x y | x <- xs, y <- xs ],
+ title "p_max" $ tests [ p_max x y | x <- xs, y <- xs ]
+ ]
diff --git a/Test/AC/Label.hs b/Test/AC/Label.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Label.hs
@@ -0,0 +1,91 @@
+{- |
+ Defines the 'Label' type, for making values 'show'able.
+-}
+
+{-# LANGUAGE FlexibleContexts #-}
+
+module Test.AC.Label where
+
+---------------------------------------------------------------------
+
+{- |
+ The @Label@ type.
+
+ A value of type @Label x@ is really a value of type @x@, but with
+ a textual label. The 'Show' instance returns this label.
+
+ This can be tremendously useful for allowing you to 'show' values
+ which would not otherwise be printable. For example, functions.
+ Rather than passing a function, you can pass a labelled function.
+ This allows you to know, at runtime, /which/ function you're
+ dealing with, which is very useful for test purposes.
+
+ You can use 'label' to extract the label text, and 'value' to
+ extract the actual data value.
+
+ The 'Show' instance uses the 'label', but the other instances use
+ only the 'value', ignoring the 'label'. (In particular, any
+ operations which alter the 'value' leave the 'label' untouched.)
+-}
+data Label x = Label {label :: String, value :: !x}
+
+instance Eq x => Eq (Label x) where
+ x == y = (value x) == (value y)
+
+instance Ord x => Ord (Label x) where
+ compare x y = compare (value x) (value y)
+
+instance Enum x => Enum (Label x) where
+ succ x = x {value = succ (value x)}
+ pred x = x {value = pred (value x)}
+ toEnum i = Label {label = "toEnum", value = toEnum i}
+ fromEnum = fromEnum . value
+ enumFrom x = map (Label (label x)) (enumFrom (value x) )
+ enumFromThen x y = map (Label (label x)) (enumFromThen (value x) (value y) )
+ enumFromTo x y = map (Label (label x)) (enumFromTo (value x) (value y) )
+ enumFromThenTo x y z = map (Label (label x)) (enumFromThenTo (value x) (value y) (value z))
+
+instance Bounded x => Bounded (Label x) where
+ minBound = Label "minBound" minBound
+ maxBound = Label "maxBound" maxBound
+
+instance Show (Label x) where show = label
+
+---------------------------------------------------------------------
+
+{- |
+ This type is similar to 'Label'. However, 'Label' cannot be made
+ an instance of higher-kinded classes such as 'Functor' and 'Monad'.
+ This type gets around that irritating limitation.
+-}
+data Label1 c x1 = Label1 {label1 :: String, value1 :: c x1}
+
+instance Eq (c x1) => Eq (Label1 c x1) where
+ x == y = (value1 x) == (value1 y)
+
+instance Ord (c x1) => Ord (Label1 c x1) where
+ compare x y = compare (value1 x) (value1 y)
+
+instance Enum (c x1) => Enum (Label1 c x1) where
+ succ x = x {value1 = succ (value1 x)}
+ pred x = x {value1 = pred (value1 x)}
+ toEnum i = Label1 {label1 = "toEnum", value1 = toEnum i}
+ fromEnum = fromEnum . value1
+ enumFrom x = map (Label1 (label1 x)) (enumFrom (value1 x) )
+ enumFromThen x y = map (Label1 (label1 x)) (enumFromThen (value1 x) (value1 y) )
+ enumFromTo x y = map (Label1 (label1 x)) (enumFromTo (value1 x) (value1 y) )
+ enumFromThenTo x y z = map (Label1 (label1 x)) (enumFromThenTo (value1 x) (value1 y) (value1 z))
+
+instance Bounded (c x1) => Bounded (Label1 c x1) where
+ minBound = Label1 "minBound" minBound
+ maxBound = Label1 "maxBound" maxBound
+
+instance Show (Label1 c x1) where show = label1
+
+instance Functor c => Functor (Label1 c) where
+ fmap f l = l {value1 = fmap f (value1 l)}
+
+instance Monad c => Monad (Label1 c) where
+ return x = Label1 {label1 = "return", value1 = return x}
+
+ lc >>= f = lc {value1 = value1 lc >>= \ x -> let lc' = f x in value1 lc'}
diff --git a/Test/AC/Private.hs b/Test/AC/Private.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Private.hs
@@ -0,0 +1,234 @@
+module Test.AC.Private
+ (
+ LogM (),
+ run, run_file,
+ log_header, log_XSL, log_element, log_element_, log_mark,
+ print_title,
+ silence_failures, stack_report, subroutine, stack_trace,
+ fail_stop,
+ log_exceptions, rawIO, force,
+ )
+ where
+
+import qualified Control.Exception as EX
+import Data.IORef
+import System.IO
+
+---------------------------------------------------------------------
+
+data State =
+ State
+ {
+ st_log_handle :: Maybe Handle,
+ st_log_prefix :: String,
+ st_fail_stop :: Bool,
+ st_fail_report :: Bool,
+ st_test_prefix :: String,
+ st_test_stack :: IORef (IO ())
+ }
+
+newtype LogM x = LogM (State -> IO x)
+
+instance Monad LogM where
+ return x = LogM $ \ _ -> return x
+
+ (LogM f1) >>= fn = LogM $ \ st -> do
+ x <- f1 st
+ let LogM f2 = fn x
+ f2 st
+
+---------------------------------------------------------------------
+
+run :: Bool -> Bool -> LogM x -> IO x
+run fail_stop fail_report (LogM f) = do
+ v <- newIORef stack_root
+ let
+ s0 =
+ State
+ {
+ st_log_handle = Nothing,
+ st_log_prefix = "",
+ st_fail_stop = fail_stop,
+ st_fail_report = fail_report,
+ st_test_prefix = "",
+ st_test_stack = v
+ }
+ f s0
+
+run_file :: FilePath -> Bool -> Bool -> LogM x -> IO x
+run_file file fail_stop fail_report (LogM f) =
+ EX.bracket
+ (do
+ putStrLn $ "Opening log file '" ++ file ++ "'..."
+ h <- openFile file WriteMode
+ hSetEncoding h utf8
+ return h
+ )
+ (\h -> do
+ putStrLn $ "Closing log file..."
+ hClose h
+ )
+ (\ h -> do
+ v <- newIORef stack_root
+ let
+ s0 =
+ State
+ {
+ st_log_handle = Just h,
+ st_log_prefix = "",
+ st_fail_stop = fail_stop,
+ st_fail_report = fail_report,
+ st_test_prefix = "",
+ st_test_stack = v
+ }
+ f s0
+ )
+
+---------------------------------------------------------------------
+
+log_write :: String -> LogM ()
+log_write txt = LogM $ \ state -> do
+ case st_log_handle state of
+ Nothing -> return ()
+ Just h -> hPutStrLn h (st_log_prefix state ++ txt)
+
+log_indent :: LogM x -> LogM x
+log_indent (LogM f) = LogM $ \ state ->
+ let state' = state {st_log_prefix = " " ++ st_log_prefix state}
+ in f state'
+
+---------------------------------------------------------------------
+
+log_header :: LogM ()
+log_header = log_write ""
+
+log_XSL :: FilePath -> LogM ()
+log_XSL f = log_write $ ""
+
+escape :: String -> String
+escape cs = do
+ c <- cs
+ case c of
+ '<' -> "<"
+ '>' -> ">"
+ '&' -> "&"
+ _ -> [c]
+
+log_element :: String -> LogM x -> LogM x
+log_element tag t = do
+ log_write $ "<" ++ tag ++ ">"
+ x <- log_indent t
+ log_write $ ""
+ return x
+
+log_element_ :: String -> String -> LogM ()
+log_element_ tag body = LogM $ \ state ->
+ case st_log_handle state of
+ Nothing -> return ()
+ Just h -> do
+ hPutStr h $ st_log_prefix state ++ "<" ++ tag ++ ">"
+ EX.catch
+ (hPutStr h (escape body))
+ (\ (EX.SomeException e) -> do
+ hPutStr h ""
+ hPutStr h (show e )
+ hPutStr h ""
+ )
+ hPutStrLn h $ ""
+
+log_mark :: String -> LogM ()
+log_mark tag = log_write $ "<" ++ tag ++ "/>"
+
+---------------------------------------------------------------------
+
+print_title :: String -> LogM ()
+print_title title = LogM $ \ state ->
+ EX.catch
+ (do
+ putStr (st_test_prefix state)
+ putStr "Test '"
+ putStr title
+ putStrLn "'"
+ )
+ (\ (EX.SomeException e) ->
+ putStrLn $ "***Exception: " ++ show e ++ " (in test title)."
+ )
+
+---------------------------------------------------------------------
+
+stack_root :: IO ()
+stack_root = seperator
+
+seperator :: IO ()
+seperator = putStrLn $ replicate 79 '-'
+
+silence_failures :: LogM x -> LogM x
+silence_failures (LogM f) = LogM $ \ state -> f $ state {st_fail_report = False}
+
+stack_report :: String -> LogM ()
+stack_report txt = LogM $ \ state -> do
+ if st_fail_report state
+ then do
+ let v = st_test_stack state
+ stack0 <- readIORef v
+ writeIORef v $ do
+ stack0
+ EX.catch
+ (putStrLn txt)
+ (\ (EX.SomeException e) -> do
+ putStr "***Exception: "
+ putStr (show e)
+ putChar '\n'
+ )
+ else return ()
+
+subroutine :: LogM x -> LogM x
+subroutine (LogM f) = LogM $ \ state0 -> do
+ let state1 = state0 {st_test_prefix = " " ++ st_test_prefix state0}
+ if st_fail_report state0
+ then do
+ let v = st_test_stack state0
+ stack0 <- readIORef v
+ writeIORef v $ stack0 >> seperator
+ x <- f state1
+ writeIORef v $ stack0
+ return x
+ else f state1
+
+stack_trace :: LogM ()
+stack_trace = LogM $ \ state -> do
+ if st_fail_report state
+ then do
+ putStrLn (replicate 79 '=')
+ putStrLn "*** Test failure ***"
+ let v = st_test_stack state
+ stack <- readIORef v
+ stack
+ putStrLn (replicate 79 '=')
+ else return ()
+
+---------------------------------------------------------------------
+
+fail_stop :: LogM Bool
+fail_stop = LogM $ \ state -> return (st_fail_stop state)
+
+---------------------------------------------------------------------
+
+log_exceptions :: LogM x -> LogM (Maybe x)
+log_exceptions (LogM act) = LogM $ \ state ->
+ EX.catch
+ (do
+ x <- act state
+ return (Just x)
+ )
+ (\ (EX.SomeException exception) -> do
+ let LogM run = log_write $ "" ++ show exception ++ ""
+ run state
+ return Nothing
+ )
+
+rawIO :: IO x -> LogM x
+rawIO act = LogM $ \ _ -> act
+
+force :: x -> LogM (Maybe x)
+force x = log_exceptions $ rawIO $ EX.evaluate x
diff --git a/Test/AC/Test.hs b/Test/AC/Test.hs
new file mode 100644
--- /dev/null
+++ b/Test/AC/Test.hs
@@ -0,0 +1,1095 @@
+{- |
+ This is the main testing module. Start reading here if you want to
+ know what this package is all about.
+
+ There's a documentation section at the bottom of this page. You
+ might want to start by reading that. Otherwise, here's a quick
+ summary:
+
+ * You create 'Test' objects to represent your tests.
+
+ * @'run_test' :: 'Test' -> 'IO' 'Bool'@ to quickly run a test
+ interactively (e.g., during debugging activity).
+
+ * 'run_test_full' allows more control, including recording detailed
+ test results to an XML log file.
+
+ * @'test' :: 'Bool' -> 'Test'@ creates a test from pure code.
+
+ * @('?=') :: 'Eq' x => x -> x -> 'Test'@ for tests with known
+ answers.
+
+ * Tests can be annotated with 'title', 'argument', 'temporary',
+ 'note' and so on.
+
+ * @'tests' :: ['Test'] -> 'Test'@ for combining multiple tests
+ into a single 'Test' object. Tests can be nested arbitrarily
+ in this mannar to group related tests together.
+
+ * @'testIO' :: 'IO' 'Bool' -> 'Test'@ for tests that need to
+ perform I/O.
+
+ * The 'TestM' monad supports 'liftIO' and allows limited test
+ annotations from within monadic code.
+
+ * @'testM' :: 'TestM' 'Bool' -> 'Test'@ to use the 'TestM' monad.
+
+ * 'throws', 'throwsIO', 'throwsM' to test for exceptions.
+-}
+
+module Test.AC.Test
+ (
+ -- * Types
+ Test(),
+
+ -- * Pure tests
+ -- ** Creation
+ -- *** Simple tests
+ test, inapplicable,
+
+ -- *** Exceptions
+ throws_, throws,
+
+ -- *** Comparisons
+ (?=), (?/=), (?<), (?<=), (?>), (?>=),
+
+ -- ** Annotations
+ title, argument, argument_, temporary, temporary_, note,
+
+ -- * Impure tests
+
+ -- ** In the @IO@ monad
+ testIO, testIO3, throws_IO, throwsIO,
+
+ -- ** In the @TestM@ monad
+ -- *** Types
+ TestM (),
+
+ -- *** Creation
+ testM, throws_M, throwsM,
+
+ -- *** Annotations
+ inapplicableM, temporaryM, temporaryM_, noteM,
+
+ -- * Combining tests
+ tests, alternatives,
+
+ -- * Running tests
+ run_test, run_test_full, TestConfig (..), default_config,
+
+ -- * Mini-guide
+ -- $Guide
+ )
+ where
+
+import Control.Monad.IO.Class
+import System.IO (stdout) -- For Haddock.
+
+import Test.AC.Private
+
+---------------------------------------------------------------------
+
+-- | An executable test.
+newtype Test = Test (LogM Bool)
+
+---------------------------------------------------------------------
+
+result_nostack :: Bool -> LogM Bool
+result_nostack b =
+ if b
+ then log_mark "pass" >> return b
+ else log_mark "fail" >> return b
+
+result :: Bool -> LogM Bool
+result b =
+ if b
+ then result_nostack b
+ else stack_trace >> result_nostack b
+
+stack_report_error :: String -> LogM ()
+stack_report_error msg = stack_report ("Test.AC.Test." ++ msg)
+
+---------------------------------------------------------------------
+
+{- |
+ Create a 'Test' from a simple 'Bool' value.
+
+ The test passes if the value is 'True'. The test fails if the value
+ is 'False', or if an exception is thrown in the course of computing
+ the value.
+-}
+test :: Bool -> Test
+test b0 = Test $ do
+ log_mark "pure"
+ log_element "result" $ do
+ mb1 <- force b0
+ case mb1 of
+ Just True -> result True
+ Just False -> do
+ stack_report_error "test: False"
+ result False
+ Nothing -> do
+ stack_report_error "test: Exception thrown."
+ result False
+
+{- |
+ This test always succeeds, but writes a note in the log to say that
+ the test case was \"inapplicable\".
+
+ This is generally useful if you have a test generation function
+ which doesn't work for certain combinations of inputs. In that
+ instance, the test still passes, but there is a note in the log
+ letting you know it was only a \"null\" test.
+-}
+inapplicable :: Test
+inapplicable = Test $ do
+ log_mark "inapplicable"
+ log_element "result" $ result_nostack True
+
+---------------------------------------------------------------------
+
+{- |
+ Test for exceptions.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the argument to
+ WHNF causes an exception to be thrown. The test /fails/ if no
+ exception is thrown.
+
+ This can be useful for checking that functions reject invalid input
+ by throwing an exception. (Of course, you cannot check that the
+ /correct/ exception is thrown!)
+
+ If WHNF is not enough to trigger the exception, you can wrap the
+ expression in some suitable forcing function. (The function
+ 'length' '.' 'show' can sometimes be used for this purpose.)
+
+ Note that an infinite loop is not an exception (unless the loop
+ exhausts some resource).
+
+ If an exception is not thrown, the actual value returned is not
+ recorded. See 'throws' for a function that records this
+ information. (Note that this requires adding a 'Show' constraint.)
+-}
+throws_ :: x -> Test
+throws_ x0 = Test $
+ log_element "result" $ do
+ mx1 <- force x0
+ case mx1 of
+ Just _ -> do
+ stack_report_error "throws_: No exception was thrown."
+ result False
+ Nothing -> result True
+
+{- |
+ Test for exceptions.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the argument to
+ WHNF causes an exception to be thrown. The test /fails/ if no
+ exception is thrown.
+
+ This can be useful for checking that functions reject invalid input
+ by throwing an exception. (Of course, you cannot check that the
+ /correct/ exception is thrown!)
+
+ If WHNF is not enough to trigger the exception, you can wrap the
+ expression in some suitable forcing function. (The function
+ 'length' '.' 'show' can sometimes be used for this purpose.)
+
+ Note that an infinite loop is not an exception (unless the loop
+ exhausts some resource).
+
+ If no exception is thrown, the actual value returned is recorded.
+ This requires adding a 'Show' constraint. See 'throws_' for a
+ function without this constraint.
+-}
+throws :: Show x => x -> Test
+throws x0 = Test $
+ log_element "result" $ do
+ mx1 <- force x0
+ case mx1 of
+ Just x1 -> do
+ log_element_ "value" $ show x1
+ stack_report_error "throws: No exception was thrown."
+ stack_report $ "Result: " ++ show x1
+ result False
+ Nothing -> result True
+
+---------------------------------------------------------------------
+
+infix 4 ?=, ?/=, ?<, ?<=, ?>, ?>=
+
+{- |
+ Compare two values for equality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if both values are equal according to '=='. The test fails
+ if any exceptions are thrown by '==' or 'show'.
+
+ This operator has the same precedence as '==' (i.e., 4).
+-}
+(?=) :: (Eq x, Show x) => x -> x -> Test
+(?=) =
+ test_compare
+ (==)
+ (log_mark "equal-to-target")
+ "(?=): Values do not match."
+ "(?=): Exception in Prelude.(==)."
+
+{- |
+ Compare two values for inequality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if both values are unequal according to '/='. The test fails
+ if any exceptions are thrown by '/=' or 'show'.
+
+ This operator has the same precedence as '/=' (i.e., 4).
+-}
+(?/=) :: (Eq x, Show x) => x -> x -> Test
+(?/=) =
+ test_compare
+ (/=)
+ (log_mark "not-equal-to-target")
+ "(?/=): Values are equal."
+ "(?/=): Exception in Prelude.(/=)."
+
+{- |
+ Compare two values for inequality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if the actual value is less than the target value according
+ to '<'. The test fails if any exceptions are thrown by '<' or
+ 'show'.
+
+ This operator has the same precedence as '<' (i.e., 4).
+-}
+(?<) :: (Ord x, Show x) => x -> x -> Test
+(?<) =
+ test_compare
+ (<)
+ (log_mark "less-than-target")
+ "(?<): Actual is no less than target."
+ "(?<): Exception in Prelude.(<)."
+
+{- |
+ Compare two values for inequality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if the actual value is less than or equal to the target
+ value according to '<='. The test fails if any exceptions are
+ thrown by '<=' or 'show'.
+
+ This operator has the same precedence as '<=' (i.e., 4).
+-}
+(?<=) :: (Ord x, Show x) => x -> x -> Test
+(?<=) =
+ test_compare
+ (<=)
+ (log_mark "less-than-target" >> log_mark "equal-to-target")
+ "(?<=): Actual is greater than target."
+ "(?<=): Exception in Prelude.(<=)."
+
+{- |
+ Compare two values for inequality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if the actual value is more than the target value according
+ to '>'. The test fails if any exceptions are thrown by '>' or
+ 'show'.
+
+ This operator has the same precedence as '>' (i.e., 4).
+-}
+(?>) :: (Ord x, Show x) => x -> x -> Test
+(?>) =
+ test_compare
+ (>)
+ (log_mark "more-than-target")
+ "(?>): Actual is no greater than target."
+ "(?>): Exception in Prelude.(>)."
+
+{- |
+ Compare two values for inequality.
+
+ The right-hand value is the \"target\" value, and the left-hand
+ value (next to the @?@ sign) is the \"actual\" value. The test
+ passes if the actual value is more than or equal to the target
+ value according to '>='. The test fails if any exceptions are
+ thrown by '>=' or 'show'.
+
+ This operator has the same precedence as '>=' (i.e., 4).
+-}
+(?>=) :: (Ord x, Show x) => x -> x -> Test
+(?>=) =
+ test_compare
+ (>=)
+ (log_mark "more-than-target" >> log_mark "equal-to-target")
+ "(?>=): Actual is less than target."
+ "(?>=): Exception in Prelude.(>=)."
+
+test_compare :: (Show x) => (x -> x -> Bool) -> LogM () -> String -> String -> x -> x -> Test
+test_compare op marks msg_fail msg_exception act exp = Test $ do
+ log_mark "pure"
+ log_element "compare" $ do
+ marks
+ log_element_ "target" (show exp)
+ log_element_ "actual" (show act)
+ stack_report $ "Target: " ++ show exp
+ stack_report $ "Actual: " ++ show act
+ log_element "result" $ do
+ mb1 <- force (act `op` exp)
+ case mb1 of
+ Just True -> result True
+ Just False -> do
+ stack_report_error msg_fail
+ result False
+ Nothing -> do
+ stack_report_error msg_exception
+ result False
+
+---------------------------------------------------------------------
+
+perform_test :: String -> LogM Bool -> LogM Bool
+perform_test name test = do
+ mb <- log_exceptions test
+ case mb of
+ Just b -> return b
+ Nothing -> do
+ stack_report_error (name ++ ": Exception accessing test object.")
+ log_element "result" $ result False
+
+{- |
+ Attach a title to a test.
+
+ This title is an arbitrary human-readable label. It is recorded in
+ relation to the test, but has no other function.
+-}
+title :: String -> Test -> Test
+title title (Test test) = Test $ do
+ log_element_ "title" title
+ stack_report ("Test '" ++ title ++ "'")
+ print_title title
+ perform_test "title" test
+
+{- |
+ Attach an argument value note.
+
+ The 'String' is the argument name, and the @x@ is that argument's
+ value, which must implement 'show'.
+-}
+argument :: (Show x) => String -> x -> Test -> Test
+argument name x = argument_ name (show x)
+
+{- |
+ Attach an argument value note.
+
+ The first 'String' is the argument name, and the second is some
+ suitable textual representation of that argument's value.
+-}
+argument_ :: String -> String -> Test -> Test
+argument_ name x (Test test) = Test $ do
+ log_element "argument" $ do
+ log_element_ "name" name
+ log_element_ "value" x
+ stack_report $ "Argument '" ++ name ++ "' = " ++ x
+ perform_test "argument_" test
+
+{- |
+ Note down a temporary intermediate value computed in the process
+ of constructing a test.
+
+ The 'String' is a name for this value, and the @x@ is the value
+ itself, which must implement 'show'.
+-}
+temporary :: (Show x) => String -> x -> Test -> Test
+temporary name x = temporary_ name (show x)
+
+{- |
+ Note down a temporary intermediate value computed in the process
+ of constructing a test.
+
+ The first 'String' is the temporary name, and the second is some
+ suitable textual representation of the temporary's value.
+-}
+temporary_ :: String -> String -> Test -> Test
+temporary_ name x (Test test) = Test $ do
+ log_element "temporary" $ do
+ log_element_ "name" name
+ log_element_ "value" x
+ stack_report $ "Temporary '" ++ name ++ "' = " ++ x
+ perform_test "temporary_" test
+
+{- |
+ Add a textual note to the test log.
+-}
+note :: String -> Test -> Test
+note txt (Test test) = Test $ do
+ log_element_ "note" txt
+ stack_report $ "Note: " ++ txt
+ perform_test "note" test
+
+---------------------------------------------------------------------
+
+{- |
+ Create a 'Test' from an 'IO' action that returns a 'Bool'.
+
+ The test passes if the value returned is 'True'. The test fails if
+ the value returned is 'False', or if an uncaught exception escapes.
+-}
+testIO :: IO Bool -> Test
+testIO act = Test $ do
+ log_mark "impure"
+ mb0 <- log_element "run" $ log_exceptions $ rawIO act
+ log_element "result" $ do
+ mb1 <- maybe (return Nothing) force mb0
+ case mb1 of
+ Just True -> result True
+ Just False -> do
+ stack_report_error "testIO: return False"
+ result False
+ Nothing -> do
+ stack_report_error "testIO: Uncaught exception."
+ result False
+
+{- |
+ Create a 'Test' from an 'IO' action with seperate set-up and
+ clean-up phases.
+
+ The first argument is a set-up action. This might be used to
+ initialise mutable storage or create disk structures, or just to
+ open some handles. Its result is passed to the second argument,
+ which then does the actual test propper. Finally, the third
+ argument is run (again with the set-up result as argument) to do
+ any post-test clean-up operations required. Its result is
+ discarded.
+
+ If any of these 'IO' actions throw an exception, the test is
+ marked failed. Note that if the set-up action throws an exception,
+ the test and clean-up actions are not run. (If only the main test
+ action throws an exception, the clean-up is still run.)
+-}
+testIO3 :: IO x -> (x -> IO Bool) -> (x -> IO y) -> Test
+testIO3 act1 act2 act3 = Test $ do
+ log_mark "impure"
+ mx <- log_element "set-up" $ log_exceptions $ rawIO act1
+ case mx of
+ Nothing -> do
+ stack_report_error "testIO3: Uncaught exception in set-up."
+ log_element "result" $ result False
+ Just x -> do
+ mb0 <- log_element "run" $ log_exceptions $ rawIO (act2 x)
+ mc <- log_element "clean-up" $ log_exceptions $ rawIO (act3 x)
+ log_element "result" $ do
+ mb1 <- maybe (return Nothing) force mb0
+ case mb1 of
+ Just True ->
+ case mc of
+ Just _ -> result True
+ Nothing -> do
+ stack_report_error "testIO3: Uncaught exception in clean-up."
+ result False
+ Just False -> do
+ stack_report_error "testIO3: return False"
+ result False
+ Nothing -> do
+ stack_report_error "testIO3: Uncaught exception."
+ result False
+
+{- |
+ Test for exceptions in the 'IO' monad.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the action's
+ result to WHNF causes an exception to be thrown. The test /fails/
+ if no exception is thrown.
+
+ This can be useful for checking that a function rejects invalid
+ input by throwing an exception, or that invalid I/O operations are
+ reported. (Of course, you cannot check that the /correct/ exception
+ is thrown!)
+
+ Note that the 'IO' action is run /and/ its result is reduced (to
+ WHNF only). Note also that infinite loops are not exceptions
+ (unless the loop exhausts some resource).
+
+ If no exception is thrown, the actual value returned is not
+ recorded. See 'throwsIO' for a function which does record this
+ information. (This requires adding a 'Show' constraint.)
+-}
+throws_IO :: IO x -> Test
+throws_IO act = Test $ do
+ mx0 <- log_element "run" $ log_exceptions $ rawIO act
+ log_element "result" $ do
+ case mx0 of
+ Nothing -> result True
+ Just x0 -> do
+ mx1 <- force x0
+ case mx1 of
+ Nothing -> result True
+ Just _ -> do
+ stack_report_error "throwsIO: No exception was thrown."
+ result False
+
+{- |
+ Test for exceptions in the 'IO' monad.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the action's
+ result to WHNF causes an exception to be thrown. The test /fails/
+ if no exception is thrown.
+
+ This can be useful for checking that a function rejects invalid
+ input by throwing an exception, or that invalid I/O operations are
+ reported. (Of course, you cannot check that the /correct/ exception
+ is thrown!)
+
+ Note that the 'IO' action is run /and/ its result is reduced (to
+ WHNF only). Note also that infinite loops are not exceptions
+ (unless the loop exhausts some resource).
+
+ If no exception is thrown, the actual value returned is recorded.
+ This requires adding a 'Show' constraint; see 'throws_IO' for a
+ function without this constraint.
+-}
+throwsIO :: Show x => IO x -> Test
+throwsIO act = Test $ do
+ mx0 <- log_element "run" $ log_exceptions $ rawIO act
+ log_element "result" $ do
+ case mx0 of
+ Nothing -> result True
+ Just x0 -> do
+ mx1 <- force x0
+ case mx1 of
+ Nothing -> result True
+ Just x1 -> do
+ log_element_ "value" $ show x1
+ stack_report_error "throwsIO: No exception was thrown."
+ stack_report $ "Result: " ++ show x1
+ result False
+
+---------------------------------------------------------------------
+
+{- |
+ The test monad.
+
+ Notice the 'MonadIO' instance. This allows you to call 'liftIO' to
+ perform arbitrary 'IO' actions at any point within the test monad.
+-}
+newtype TestM x = TestM (LogM x)
+
+instance Monad TestM where
+ return = TestM . return
+
+ (TestM m1) >>= f = TestM $ m1 >>= \ x -> let TestM m2 = f x in m2
+
+instance MonadIO TestM where
+ liftIO act = TestM $ rawIO act
+
+---------------------------------------------------------------------
+
+{- |
+ Create a 'Test' from a 'TestM' action.
+
+ The test passes if the 'TestM' action returns 'True'. The test
+ fails if it returns 'False' or an uncaught exception escapes.
+-}
+testM :: TestM Bool -> Test
+testM (TestM act) = Test $ do
+ log_mark "impure"
+ mb0 <- log_element "run" $ log_exceptions act
+ log_element "result" $ do
+ mb1 <- maybe (return Nothing) force mb0
+ case mb1 of
+ Just True -> result True
+ Just False -> do
+ stack_report_error "testM: return False"
+ result False
+ Nothing -> do
+ stack_report_error "testM: Uncaught exception."
+ result False
+
+{- |
+ Check a 'TestM' action for exceptions.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the action's
+ result to WHNF causes an exception to be thrown. The test /fails/
+ if no exception is thrown.
+
+ This can be useful for checking that a function rejects invalid
+ input by throwing an exception, or that invalid I/O operations are
+ reported. (Of course, you cannot check that the /correct/ exception
+ is thrown!)
+
+ Note that the 'TestM' action is run /and/ its result is reduced (to
+ WHNF only). Note also that infinite loops are not exceptions
+ (unless the loop exhausts some resource).
+
+ If no exception is thrown, the actual value returned is not
+ recorded. See 'throwsM' for a function that does record the value.
+ This requires adding a 'Show' constraint.
+-}
+throws_M :: TestM x -> Test
+throws_M (TestM act) = Test $ do
+ log_mark "impure"
+ mx0 <- log_element "run" $ log_exceptions act
+ log_element "result" $ do
+ case mx0 of
+ Nothing -> result True
+ Just x0 -> do
+ mx1 <- force x0
+ case mx1 of
+ Nothing -> result True
+ Just _ -> do
+ stack_report_error "throwsM: No exception was thrown."
+ result False
+
+{- |
+ Check a 'TestM' action for exceptions.
+
+ Ordinarily, any test which throws an exception is deemed to have
+ failed. However, this test /passes/ if evaluating the action's
+ result to WHNF causes an exception to be thrown. The test /fails/
+ if no exception is thrown.
+
+ This can be useful for checking that a function rejects invalid
+ input by throwing an exception, or that invalid I/O operations are
+ reported. (Of course, you cannot check that the /correct/ exception
+ is thrown!)
+
+ Note that the 'TestM' action is run /and/ its result is reduced (to
+ WHNF only). Note also that infinite loops are not exceptions
+ (unless the loop exhausts some resource).
+
+ If no exception is thrown, the actual value returns is recorded.
+ This requires adding a 'Show' constraint. See 'throws_M' for a
+ function without this constraint.
+-}
+throwsM :: Show x => TestM x -> Test
+throwsM (TestM act) = Test $ do
+ log_mark "impure"
+ mx0 <- log_element "run" $ log_exceptions act
+ log_element "result" $ do
+ case mx0 of
+ Nothing -> result True
+ Just x0 -> do
+ mx1 <- force x0
+ case mx1 of
+ Nothing -> result True
+ Just x1 -> do
+ log_element_ "value" $ show x1
+ stack_report_error "throwsM: No exception was thrown."
+ stack_report $ "Result: " ++ show x1
+ result False
+
+---------------------------------------------------------------------
+
+{- |
+ Mark the current test as \"inapplicable\" and return 'True'.
+ (See 'inapplicable'.)
+-}
+inapplicableM :: TestM Bool
+inapplicableM = TestM $ do
+ log_mark "inapplicable"
+ return True
+
+{- |
+ Note down a temporary intermediate value computed in the process
+ of constructing a test.
+
+ The 'String' is a name for this value, and the @x@ is the value
+ itself, which must implement 'show'.
+-}
+temporaryM :: (Show x) => String -> x -> TestM ()
+temporaryM name x = temporaryM_ name (show x)
+
+{- |
+ Note down a temporary intermediate value computed in the process
+ of constructing a test.
+
+ The first 'String' is the name, and the second is some suitable
+ textual representation of the value.
+-}
+temporaryM_ :: String -> String -> TestM ()
+temporaryM_ name x = TestM $ do
+ log_element "temporary" $ do
+ log_element_ "name" name
+ log_element_ "value" x
+ stack_report $ "Temporary '" ++ name ++ "' = " ++ x
+
+{- |
+ Add a textual note to the log file.
+-}
+noteM :: String -> TestM ()
+noteM txt = TestM $ do
+ log_element_ "note" txt
+ stack_report $ "Note: " ++ txt
+
+---------------------------------------------------------------------
+
+{- |
+ Combine multiple tests into a single composite test.
+
+ The composite test fails if any of its constituent tests fail.
+ Whether the remaining tests are run depends on the testing mode
+ (the 'cfg_FailAbort' parameter in 'TestConfig').
+
+ Essentially, this takes the logical-AND of several tests. You can
+ achieve the same result using the normal '&&' operator or the 'and'
+ function, operating on plain 'Bool' values rather than 'Test'
+ objects. However, by turning subexpressions into 'Test' objects and
+ using 'tests', the result of each subexpression will be logged to
+ file in addition to the overall result. Depending on the context,
+ that may or may not be helpful. You decide which you want.
+-}
+tests :: [Test] -> Test
+tests = Test . root
+ where
+ root ts = do
+ mb <- log_element "tests" $ work True ts
+ log_element "result" $
+ case mb of
+ Just b -> result_nostack b
+ Nothing -> result False
+
+ work b0 ts0 = do
+ mts1 <- force ts0
+ case mts1 of
+ Just [] -> return (Just b0)
+ Just (Test t : ts2) -> do
+ b1 <- subroutine $ log_element "test" $ perform_test "tests" t
+ if b0 && b1
+ then work True ts2
+ else do
+ s <- fail_stop
+ if s
+ then return (Just False)
+ else work False ts2
+ Nothing -> do
+ stack_report_error "tests: Exception accessing test list spine."
+ return Nothing
+
+{- |
+ Create a composite test which passes if at least one child test
+ passes.
+
+ All child tests are always run, regardless of error reporting mode.
+ No test failures are reported, unless all children fail.
+
+ Essentially, this takes the logical-OR of several tests. You can
+ achieve the same result using the normal '||' operator or the 'or'
+ function, operating on plain 'Bool' values rather than 'Test'
+ objects. However, by turning subexpressions into 'Test' objects and
+ using 'alternatives', the result of each subexpression will be
+ logged to file in addition to the overall result. Depending on the
+ context, that may or may not be helpful. You decide which you want.
+-}
+alternatives :: [Test] -> Test
+alternatives = Test . root
+ where
+ root ts = do
+ mb <- log_element "alternatives" $ work False ts
+ log_element "result" $
+ case mb of
+ Just True -> result True
+ Just False -> do
+ stack_report_error "alternatives: All child tests failed."
+ result False
+ Nothing -> result False
+
+ work b0 ts0 = do
+ mts1 <- force ts0
+ case mts1 of
+ Just [] -> return (Just b0)
+ Just (Test t : ts2) -> do
+ b1 <- log_element "test" $ silence_failures $ subroutine $ perform_test "alternatives" t
+ work (b0 || b1) ts2
+ Nothing -> do
+ stack_report_error "alternatives: Exception accessing test list spine."
+ return Nothing
+
+---------------------------------------------------------------------
+
+{- |
+ Execute a test.
+
+ Ordinarily, \"the test\" will be a composite test created with
+ 'tests', and will actually contain multiple sub-tests within it.
+
+ A 'Bool' value is returned indicating whether the test was
+ successful or not. Test progress information is printed to
+ 'stdout'. If any test fails, detailed information for that test is
+ printed to 'stdout', and testing aborts.
+
+ For more control, see 'run_test_full'.
+-}
+run_test :: Test -> IO Bool
+run_test = run_test_full default_config
+
+{- |
+ Execute a test.
+
+ Ordinarily, \"the test\" will be a composite test created with
+ 'tests', and will actually contain multiple sub-tests within it.
+
+ A 'Bool' value is returned indicating whether the test was
+ successful or not. Test progress information is printed to
+ 'stdout'. Various testing options can be configured using the
+ 'TestConfig' argument. In particular, it is possible to log
+ detailed testing data to an XML log file (the 'cfg_LogFile'
+ parameter).
+
+ The related 'run_test' function runs a test with the
+ 'default_config' test settings, which are useful for quick
+ interactive testing during a debugging session.
+-}
+run_test_full :: TestConfig -> Test -> IO Bool
+run_test_full c (Test t) = do
+ putStrLn "Starting test run..."
+ b <- case cfg_LogFile c of
+ Nothing -> run (cfg_FailAbort c) (cfg_FailReport c) $ t
+ Just f1 -> run_file f1 (cfg_FailAbort c) (cfg_FailReport c) $ do
+ log_header
+ case cfg_LogXSL c of
+ Nothing -> return ()
+ Just f2 -> log_XSL f2
+ log_element "test" t
+ putStr "Test run "
+ if b
+ then putStrLn "PASSED."
+ else putStrLn "FAILED."
+ putStrLn ""
+ return b
+
+-- | Configuration settings for a test run.
+data TestConfig =
+ TestConfig
+ {
+ {- |
+ If 'Nothing', no log file is produced. Otherwise, this is the
+ full path to the XML log file.
+ -}
+ cfg_LogFile :: Maybe FilePath,
+
+ {- |
+ Path to an XSL file. If given, the XML log file will use this
+ XSL as a stylesheet. This value is ignored if no XML log is
+ produced.
+ -}
+ cfg_LogXSL :: Maybe String,
+
+ {- |
+ If 'True', report test failures to 'stdout'. If 'False', just
+ report test progress to 'stdout'.
+ -}
+ cfg_FailReport :: Bool,
+
+ {- |
+ If 'True', abort testing if a test fails, otherwise continue
+ testing. (In other words, 'False' causes /all/ tests to be
+ run, regardless of test failures, while 'True' runs until a
+ test fails and then stops.)
+ -}
+ cfg_FailAbort :: Bool
+ }
+
+{- |
+ The default test configuration, as used by 'run_test'.
+
+ >cfg_LogFile = Nothing
+ >cfg_LogXSL = Nothing
+ >cfg_FailReport = True
+ >cfg_FailAbort = True
+
+ You can use this as a starting point if you only want to customise
+ a few test settings. (More options may be added in future.)
+-}
+default_config :: TestConfig
+default_config =
+ TestConfig
+ {
+ cfg_LogFile = Nothing,
+ cfg_LogXSL = Nothing,
+ cfg_FailReport = True,
+ cfg_FailAbort = True
+ }
+
+---------------------------------------------------------------------
+
+{- $Guide
+ Tests are represented by 'Test' objects.
+
+ You can run such a test using
+ @'run_test' :: 'Test' -> 'IO' 'Bool'@.
+ This is intended for quickly running a test or two interactively to
+ see if those code changes you just made fixed the bug or not. For
+ running an entire test suite, you probably want 'run_test_full'.
+ This uses a 'TestConfig' object to set testing options; in
+ particular, detailed test information can be written to an XML log
+ file. Most test annotations only affect the log file, not the
+ visible output on 'stdout'.
+
+ You can create a test in several ways. The easiest is
+ @'test' :: 'Bool' -> 'Test'@.
+ For example, a simple hard-coded test might look like
+
+ >t_null_empty :: Test
+ >t_null_empty = test $ SET.null SET.empty
+
+ You can also add a test title:
+
+ >t_null_empty :: Test
+ >t_null_empty =
+ > title "null empty" $
+ > test $
+ > SET.null SET.empty
+
+ Running this test produces a log entry which looks something like
+
+ >
+ > null empty
+ >
+ >
+ >
+
+ (Assuming the implementation of your 'SET' module isn't broken,
+ obviously.) I like to set the test 'title' to be the Haskell
+ expression that I'm testing (or some approximation of it), but
+ there's no law that says you have to do it like that. You can name
+ it whatever you like.
+
+ More often, you'll have a function that takes some inputs and
+ generates a test object. For example:
+
+ >p_head_member :: Ord x => [x] -> Test
+ >p_head_member xs =
+ > title "head xs `member` fromList xs" $
+ > argument "xs" xs $
+ > let set = SET.fromList xs in
+ > temporary "fromList xs" set $
+ > if LIST.null xs
+ > then inapplicable
+ > else test $ head xs `SET.member` set
+
+ Running this test might produce a log entry such as
+
+ >
+ > head xs `member` fromList xs
+ > xsfromList [3,1,4]
+ > fromList xsfromList [1,3,4]
+ >
+ >
+ >
+
+ Of course, 'head' is not defined on an empty list. In that case,
+ the code above is configured to mark the test as 'inapplicable'.
+ The resulting log entry looks like
+
+ >
+ > head xs `member` fromList xs
+ > xsfromList []
+ > fromList xsfromList []
+ >
+ >
+ >
+
+ The test is still \"successul\", but we have marked it so that
+ anyone reading the log will know that this particular test
+ \"did nothing\".
+
+ For tests with a known correct answer, you can also use the
+ @('?=') :: 'Eq' x => x -> x -> 'Test'@
+ operator. For example,
+
+ >p_size :: Ord x => [x] -> Test
+ >p_size xs =
+ > title "size (fromList xs) == length (nub xs)" $
+ > argument "xs" xs $
+ > temporary "fromList xs" (SET.fromList xs) $
+ > temporary "nub xs" (LIST.nub xs) $
+ > SET.size (SET.fromList xs) ?= LIST.length (LIST.nub xs)
+
+ Running that might produce something like
+
+ >
+ > size (fromList xs) == length (nub xs)
+ > xs[3,1,4,1]
+ > fromList xsfromList [1,3,4]
+ > nub xs[3,1,4]
+ >
+ >
+ >
+ > 3
+ > 3
+ >
+ >
+ >
+
+ In this instance, the output indicates that @size (fromList xs)@
+ was supposed to yield 3, and the value /actually/ produced was also
+ 3 - and hence, the test passed. There are several similar operators
+ such as '?>', '?<' and so forth for inequality testing using an
+ 'Ord' instance.
+
+ One test case probably isn't particularly useful. But using the
+ @'tests' :: ['Test'] -> 'Test'@
+ function, you can combine multiple tests into a single composite
+ 'Test' object. You can have multiple levels of this grouping to
+ organise related tests together. Composite tests can of course
+ have titles just like any other kind of test.
+
+ Note that this package (unlike, say, QuickCheck) provides no
+ facility for generating test data automatically. That's your
+ problem. You can solve it in several ways. One idea might be
+
+ >t_size :: Test
+ >t_size = tests $ map p_size [ [], [5], [5,5], [4,6], [1..10] ]
+
+ Because this package doesn't deal with test data generation, you
+ are free to use any approach you like. In particular, different
+ properties can be tested with different test data (rather than
+ relying on the type system to select test data for you), the data
+ can be random or deterministic, and it can even be loaded from an
+ external disk file if you like. Hell, you can even spawn an
+ external OS process running a reference implementation, and then
+ compare the results from your Haskell code against that. The choice
+ is endless.
+
+ If you want to test code that needs to perform I/O, you can use the
+ @'testIO' :: 'IO' 'Bool' -> 'Test'@
+ function. Impure tests such as this can be annotated in all the
+ usual ways. For example,
+
+ >p_makedir :: FilePath -> Test
+ >p_makedir dir =
+ > title "p_makedir" $
+ > argument "dir" dir $
+ > testIO $ do
+ > createDirectory dir
+ > doesDirectoryExist dir
+
+ If the test involves setup and cleanup steps, or just resource
+ allocation and subsequent deallocation, then you can build those
+ into the main test body, or you can use 'testIO3' instead. This has
+ the added advantage that it handles exceptions in the test body and
+ still runs the cleanup stage. (We /are/ testing code which might
+ well crash, after all.) The choice is entirely up to you.
+
+ While you're in the 'IO' monad, you unfortunately cannot use
+ functions such as 'temporary' or 'note'. To get around this
+ limitation, you can use the 'TestM' monad. It implements 'liftIO',
+ so you can still perform any I/O operations you want. But it also
+ provides 'temporaryM' and 'noteM', which run inside the monad. The
+ @'testM' :: 'TestM' 'Bool' -> 'Test'@ function lets you wrap
+ everything up onto a regular 'Test' object when you're done.
+
+ Some functions (e.g., 'head') are supposed to throw an exception
+ under certain circumstances. To check that they do (rather than,
+ say, return gibberish data instead), you can use 'throws' (or
+ 'throwsIO' in the 'IO' monad, or 'throwsM' in the 'TestM' monad).
+-}