AC-MiniTest (empty) → 1.1.1

raw patch · 10 files changed

+1898/−0 lines, 10 filesdep +basedep +transformerssetup-changed

Dependencies added: base, transformers

Files

AC-MiniTest.cabal +37/−0
License.txt +30/−0
Setup.hs +2/−0
Test/AC/Class/Eq.hs +69/−0
Test/AC/Class/Functor.hs +87/−0
Test/AC/Class/Monad.hs +131/−0
Test/AC/Class/Ord.hs +122/−0
Test/AC/Label.hs +91/−0
Test/AC/Private.hs +234/−0
Test/AC/Test.hs +1095/−0

+ AC-MiniTest.cabal view

@@ -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

+ License.txt view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ Test/AC/Class/Eq.hs view

@@ -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          ]
+  ]

+ Test/AC/Class/Functor.hs view

@@ -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 ]
+  ]

+ Test/AC/Class/Monad.hs view

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

+ Test/AC/Class/Ord.hs view

@@ -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          ]
+  ]

+ Test/AC/Label.hs view

@@ -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'}

+ Test/AC/Private.hs view

@@ -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 "<?xml version='1.0' encoding='utf-8'?>"
+
+log_XSL :: FilePath -> LogM ()
+log_XSL f = log_write $ "<?xml-stylesheet type='text/xsl' href='" ++ f ++ "'?>"
+
+escape :: String -> String
+escape cs = do
+  c <- cs
+  case c of
+    '<' -> "&lt;"
+    '>' -> "&gt;"
+    '&' -> "&amp;"
+    _   -> [c]
+
+log_element :: String -> LogM x -> LogM x
+log_element tag t = do
+  log_write $ "<"  ++ tag ++ ">"
+  x <- log_indent t
+  log_write $ "</" ++ tag ++ ">"
+  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  "<exception>"
+          hPutStr h (show   e   )
+          hPutStr h "</exception>"
+        )
+      hPutStrLn h $ "</" ++ tag ++ ">"
+
+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 $ "<exception>" ++ show exception ++ "</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

+ Test/AC/Test.hs view

@@ -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
+
+  >  <test>
+  >    <title>null empty</title>
+  >    <pure/>
+  >    <result><pass/></result>
+  >  </test>
+
+  (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
+
+  >  <test>
+  >    <title>head xs `member` fromList xs</title>
+  >    <argument><name>xs</name><value>fromList [3,1,4]</value></argument>
+  >    <temporary><name>fromList xs</name><value>fromList [1,3,4]</value></temporary>
+  >    <pure/>
+  >    <result><pass/></result>
+  >  </test>
+
+  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
+
+  >  <test>
+  >    <title>head xs `member` fromList xs</title>
+  >    <argument><name>xs</name><value>fromList []</value></argument>
+  >    <temporary><name>fromList xs</name><value>fromList []</value></temporary>
+  >    <inapplicable/>
+  >    <result><pass/></result>
+  >  </test>
+
+  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
+
+  >  <test>
+  >    <title>size (fromList xs) == length (nub xs)</title>
+  >    <argument><name>xs</name><value>[3,1,4,1]</value></argument>
+  >    <temporary><name>fromList xs</name><value>fromList [1,3,4]</value></temporary>
+  >    <temporary><name>nub xs</name><value>[3,1,4]</value></temporary>
+  >    <pure/>
+  >    <compare>
+  >      <equal-to-target/>
+  >      <target>3</target>
+  >      <actual>3</actual>
+  >    </compare>
+  >    <result><pass/></result>
+  >  </test>
+
+  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).
+-}