/tp-1/codigo/HUnitBase.lhs

  1HUnitBase.lhs  --  basic definitions
  2
  3$Id: HUnitBase.lhs,v 1.12 2002/02/14 19:31:57 heringto Exp $
  4
  5> module HUnitBase
  6> (
  7>   {- from HUnitLang: -} Assertion, assertFailure,
  8>   assertString, assertBool, assertEqual,
  9>   Assertable(..), ListAssertable(..),
 10>   AssertionPredicate, AssertionPredicable(..),
 11>   (@?), (@=?), (@?=),
 12>   Test(..), Node(..), Path,
 13>   testCaseCount,
 14>   Testable(..),
 15>   (~?), (~=?), (~?=), (~:),
 16>   Counts(..), State(..),
 17>   ReportStart, ReportProblem,
 18>   testCasePaths,
 19>   performTest
 20> )
 21> where
 22
 23> import Monad (unless, foldM)
 24
 25
 26Assertion Definition
 27====================
 28
 29> import HUnitLang
 30
 31
 32Conditional Assertion Functions
 33-------------------------------
 34
 35> assertBool :: String -> Bool -> Assertion
 36> assertBool msg b = unless b (assertFailure msg)
 37
 38> assertString :: String -> Assertion
 39> assertString s = unless (null s) (assertFailure s)
 40
 41> assertEqual :: (Eq a, Show a) => String -> a -> a -> Assertion
 42> assertEqual preface expected actual =
 43>   unless (actual == expected) (assertFailure msg)
 44>  where msg = (if null preface then "" else preface ++ "\n") ++
 45>              "expected: " ++ show expected ++ "\n but got: " ++ show actual
 46
 47
 48Overloaded `assert` Function
 49----------------------------
 50
 51> class Assertable t
 52>  where assert :: t -> Assertion
 53
 54> instance Assertable ()
 55>  where assert = return
 56
 57> instance Assertable Bool
 58>  where assert = assertBool ""
 59
 60> instance (ListAssertable t) => Assertable [t]
 61>  where assert = listAssert
 62
 63> instance (Assertable t) => Assertable (IO t)
 64>  where assert = (>>= assert)
 65
 66We define the assertability of `[Char]` (that is, `String`) and leave
 67other types of list to possible user extension.
 68
 69> class ListAssertable t
 70>  where listAssert :: [t] -> Assertion
 71
 72> instance ListAssertable Char
 73>  where listAssert = assertString
 74
 75
 76Overloaded `assertionPredicate` Function
 77----------------------------------------
 78
 79> type AssertionPredicate = IO Bool
 80
 81> class AssertionPredicable t
 82>  where assertionPredicate :: t -> AssertionPredicate
 83
 84> instance AssertionPredicable Bool
 85>  where assertionPredicate = return
 86
 87> instance (AssertionPredicable t) => AssertionPredicable (IO t)
 88>  where assertionPredicate = (>>= assertionPredicate)
 89
 90
 91Assertion Construction Operators
 92--------------------------------
 93
 94> infix  1 @?, @=?, @?=
 95
 96> (@?) :: (AssertionPredicable t) => t -> String -> Assertion
 97> pred @? msg = assertionPredicate pred >>= assertBool msg
 98
 99> (@=?) :: (Eq a, Show a) => a -> a -> Assertion
100> expected @=? actual = assertEqual "" expected actual
101
102> (@?=) :: (Eq a, Show a) => a -> a -> Assertion
103> actual @?= expected = assertEqual "" expected actual
104
105
106
107Test Definition
108===============
109
110> data Test = TestCase Assertion
111>           | TestList [Test]
112>           | TestLabel String Test
113
114> instance Show Test where
115>   showsPrec p (TestCase _)    = showString "TestCase _"
116>   showsPrec p (TestList ts)   = showString "TestList " . showList ts
117>   showsPrec p (TestLabel l t) = showString "TestLabel " . showString l
118>                                 . showChar ' ' . showsPrec p t
119
120> testCaseCount :: Test -> Int
121> testCaseCount (TestCase _)    = 1
122> testCaseCount (TestList ts)   = sum (map testCaseCount ts)
123> testCaseCount (TestLabel _ t) = testCaseCount t
124
125
126> data Node  = ListItem Int | Label String
127>   deriving (Eq, Show, Read)
128
129> type Path = [Node]    -- Node order is from test case to root.
130
131
132> testCasePaths :: Test -> [Path]
133> testCasePaths t = tcp t []
134>  where tcp (TestCase _) p = [p]
135>        tcp (TestList ts) p =
136>          concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]
137>        tcp (TestLabel l t) p = tcp t (Label l : p)
138
139
140Overloaded `test` Function
141--------------------------
142
143> class Testable t
144>  where test :: t -> Test
145
146> instance Testable Test
147>  where test = id
148
149> instance (Assertable t) => Testable (IO t)
150>  where test = TestCase . assert
151
152> instance (Testable t) => Testable [t]
153>  where test = TestList . map test
154
155
156Test Construction Operators
157---------------------------
158
159> infix  1 ~?, ~=?, ~?=
160> infixr 0 ~:
161
162> (~?) :: (AssertionPredicable t) => t -> String -> Test
163> pred ~? msg = TestCase (pred @? msg)
164
165> (~=?) :: (Eq a, Show a) => a -> a -> Test
166> expected ~=? actual = TestCase (expected @=? actual)
167
168> (~?=) :: (Eq a, Show a) => a -> a -> Test
169> actual ~?= expected = TestCase (actual @?= expected)
170
171> (~:) :: (Testable t) => String -> t -> Test
172> label ~: t = TestLabel label (test t)
173
174
175
176Test Execution
177==============
178
179> data Counts = Counts { cases, tried, errors, failures :: Int }
180>   deriving (Eq, Show, Read)
181
182> data State = State { path :: Path, counts :: Counts }
183>   deriving (Eq, Show, Read)
184
185> type ReportStart us = State -> us -> IO us
186
187> type ReportProblem us = String -> State -> us -> IO us
188
189
190Note that the counts in a start report do not include the test case
191being started, whereas the counts in a problem report do include the
192test case just finished.  The principle is that the counts are sampled
193only between test case executions.  As a result, the number of test
194case successes always equals the difference of test cases tried and
195the sum of test case errors and failures.
196
197
198> performTest :: ReportStart us -> ReportProblem us -> ReportProblem us
199>                  -> us -> Test -> IO (Counts, us)
200> performTest reportStart reportError reportFailure us t = do
201>   (ss', us') <- pt initState us t
202>   unless (null (path ss')) $ error "performTest: Final path is nonnull"
203>   return (counts ss', us')
204>  where
205>   initState  = State{ path = [], counts = initCounts }
206>   initCounts = Counts{ cases = testCaseCount t, tried = 0,
207>                        errors = 0, failures = 0}
208
209>   pt ss us (TestCase a) = do
210>     us' <- reportStart ss us
211>     r <- performTestCase a
212>     case r of Nothing         -> do return (ss', us')
213>               Just (True,  m) -> do usF <- reportFailure m ssF us'
214>                                     return (ssF, usF)
215>               Just (False, m) -> do usE <- reportError   m ssE us'
216>                                     return (ssE, usE)
217>    where c@Counts{ tried = t } = counts ss
218>          ss' = ss{ counts = c{ tried = t + 1 } }
219>          ssF = ss{ counts = c{ tried = t + 1, failures = failures c + 1 } }
220>          ssE = ss{ counts = c{ tried = t + 1, errors   = errors   c + 1 } }
221
222>   pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])
223>    where f (ss, us) (t, n) = withNode (ListItem n) ss us t
224
225>   pt ss us (TestLabel label t) = withNode (Label label) ss us t
226
227>   withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t
228>                                return (ss2{ path = path0 }, us1)
229>    where path0 = path ss0
230>          ss1 = ss0{ path = node : path0 }