/tp-1/codigo/HUnitBase.lhs
Haskell | 230 lines | 152 code | 72 blank | 6 comment | 2 complexity | 5aa89e490293851f865c59cfb23939f7 MD5 | raw file
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 }