HUnitTestBase.lhs  --  test support and basic tests (Haskell 98 compliant)

> {-# LANGUAGE CPP #-}

> module HUnitTestBase where

> import Data.List

> import Test.HUnit

> import Test.HUnit.Terminal (terminalAppearance)

> import System.IO (IOMode(..), openFile, hClose)

> data Report = Start State

>             | Error String State

>             | UnspecifiedError State

>             | Failure String State

>   deriving (Show, Read)

> instance Eq Report where

>   Start s1            == Start s2             =  s1 == s2

>   Error m1 s1         == Error m2 s2          =  m1 == m2 && s1 == s2

>   Error _  s1         == UnspecifiedError s2  =  s1 == s2

>   UnspecifiedError s1 == Error _  s2          =  s1 == s2

>   UnspecifiedError s1 == UnspecifiedError s2  =  s1 == s2

>   Failure m1 s1       == Failure m2 s2        =  m1 == m2 && s1 == s2

>   _                   == _                    =  False

> expectReports :: [Report] -> Counts -> Test -> Test

> expectReports reports1 counts1 t = TestCase $ do

>   (counts2, reports2) <- performTest (\  ss us -> return (Start     ss : us))

>                                      (\_loc m ss us -> return (Error   m ss : us))

>                                      (\_loc m ss us -> return (Failure m ss : us))

>                                      [] t

>   assertEqual "for the reports from a test," reports1 (reverse reports2)

>   assertEqual "for the counts from a test," counts1 counts2

> simpleStart :: Report

> simpleStart = Start (State [] (Counts 1 0 0 0))

> expectSuccess :: Test -> Test

> expectSuccess = expectReports [simpleStart] (Counts 1 1 0 0)

> expectProblem :: (String -> State -> Report) -> Int -> String -> Test -> Test

> expectProblem kind err msg =

>   expectReports [simpleStart, kind msg (State [] counts')] counts'

>  where counts' = Counts 1 1 err (1-err)

> expectError, expectFailure :: String -> Test -> Test

> expectError   = expectProblem Error   1

> expectFailure = expectProblem Failure 0

> expectUnspecifiedError :: Test -> Test

> expectUnspecifiedError = expectProblem (\ _msg st -> UnspecifiedError st) 1 undefined

> data Expect = Succ | Err String | UErr | Fail String

> expect :: Expect -> Test -> Test

> expect Succ     t = expectSuccess t

> expect (Err m)  t = expectError m t

> expect UErr     t = expectUnspecifiedError t

> expect (Fail m) t = expectFailure m t

> baseTests :: Test

> baseTests = test [ assertTests,

>                    testCaseCountTests,

>                    testCasePathsTests,

>                    reportTests,

>                    textTests,

>                    showPathTests,

>                    showCountsTests,

>                    assertableTests,

>                    predicableTests,

>                    compareTests,

>                    extendedTestTests ]

> ok :: Test

> ok = test (assert ())

> bad :: String -> Test

> bad m = test (assertFailure m :: Assertion)

> assertTests :: Test

> assertTests = test [

>   "null" ~: expectSuccess ok,

>   "userError" ~:

>     expectError "user error (error)" (TestCase (ioError (userError "error"))),

>   "IO error (file missing)" ~:

>     expectUnspecifiedError

>       (test (do _ <- openFile "3g9djs" ReadMode; return ())),

   "error" ~:

     expectError "error" (TestCase (error "error")),

   "tail []" ~:

     expectUnspecifiedError (TestCase (tail [] `seq` return ())),

    -- GHC doesn't currently catch arithmetic exceptions.

   "div by 0" ~:

     expectUnspecifiedError (TestCase ((3 `div` 0) `seq` return ())),

>   "assertFailure" ~:

>     let msg = "simple assertFailure"

>     in expectFailure msg (test (assertFailure msg :: Assertion)),

>   "assertString null" ~: expectSuccess (TestCase (assertString "")),

>   "assertString nonnull" ~:

>     let msg = "assertString nonnull"

>     in expectFailure msg (TestCase (assertString msg)),

>   let f v non =

>         show v ++ " with " ++ non ++ "null message" ~:

>           expect (if v then Succ else Fail non) $ test $ assertBool non v

>   in "assertBool" ~: [ f v non | v <- [True, False], non <- ["non", ""] ],

>   let msg = "assertBool True"

>   in msg ~: expectSuccess (test (assertBool msg True)),

>   let msg = "assertBool False"

>   in msg ~: expectFailure msg (test (assertBool msg False)),

>   "assertEqual equal" ~:

>     expectSuccess (test (assertEqual "" (3 :: Integer) (3 :: Integer))),

>   "assertEqual unequal no msg" ~:

>     expectFailure "expected: 3\n but got: 4"

>       (test (assertEqual "" (3 :: Integer) (4 :: Integer))),

>   "assertEqual unequal with msg" ~:

>     expectFailure "for x,\nexpected: 3\n but got: 4"

>       (test (assertEqual "for x," (3 :: Integer) (4 :: Integer)))

>  ]

> emptyTest0, emptyTest1, emptyTest2 :: Test

> emptyTest0 = TestList []

> emptyTest1 = TestLabel "empty" emptyTest0

> emptyTest2 = TestList [ emptyTest0, emptyTest1, emptyTest0 ]

> emptyTests :: [Test]

> emptyTests = [emptyTest0, emptyTest1, emptyTest2]

> testCountEmpty :: Test -> Test

> testCountEmpty t = TestCase (assertEqual "" 0 (testCaseCount t))

> suite0, suite1, suite2, suite3 :: (Integer, Test)

> suite0 = (0, ok)

> suite1 = (1, TestList [])

> suite2 = (2, TestLabel "3" ok)

> suite3 = (3, suite)

> suite :: Test

> suite =

>   TestLabel "0"

>     (TestList [ TestLabel "1" (bad "1"),

>                 TestLabel "2" (TestList [ TestLabel "2.1" ok,

>                                           ok,

>                                           TestLabel "2.3" (bad "2") ]),

>                 TestLabel "3" (TestLabel "4" (TestLabel "5" (bad "3"))),

>                 TestList [ TestList [ TestLabel "6" (bad "4") ] ] ])

> suiteCount :: Int

> suiteCount = 6

> suitePaths :: [[Node]]

> suitePaths = [

>   [Label "0", ListItem 0, Label "1"],

>   [Label "0", ListItem 1, Label "2", ListItem 0, Label "2.1"],

>   [Label "0", ListItem 1, Label "2", ListItem 1],

>   [Label "0", ListItem 1, Label "2", ListItem 2, Label "2.3"],

>   [Label "0", ListItem 2, Label "3", Label "4", Label "5"],

>   [Label "0", ListItem 3, ListItem 0, ListItem 0, Label "6"]]

> suiteReports :: [Report]

> suiteReports = [ Start       (State (p 0) (Counts 6 0 0 0)),

>                  Failure "1" (State (p 0) (Counts 6 1 0 1)),

>                  Start       (State (p 1) (Counts 6 1 0 1)),

>                  Start       (State (p 2) (Counts 6 2 0 1)),

>                  Start       (State (p 3) (Counts 6 3 0 1)),

>                  Failure "2" (State (p 3) (Counts 6 4 0 2)),

>                  Start       (State (p 4) (Counts 6 4 0 2)),

>                  Failure "3" (State (p 4) (Counts 6 5 0 3)),

>                  Start       (State (p 5) (Counts 6 5 0 3)),

>                  Failure "4" (State (p 5) (Counts 6 6 0 4))]

>  where p n = reverse (suitePaths !! n)

> suiteCounts :: Counts

> suiteCounts = Counts 6 6 0 4

> suiteOutput :: String

> suiteOutput = concat [

>    "### Failure in: 0:0:1\n",

>    "1\n",

>    "### Failure in: 0:1:2:2:2.3\n",

>    "2\n",

>    "### Failure in: 0:2:3:4:5\n",

>    "3\n",

>    "### Failure in: 0:3:0:0:6\n",

>    "4\n",

>    "Cases: 6  Tried: 6  Errors: 0  Failures: 4\n"]

> suites :: [(Integer, Test)]

> suites = [suite0, suite1, suite2, suite3]

> testCount :: Show n => (n, Test) -> Int -> Test

> testCount (num, t) count =

>   "testCaseCount suite" ++ show num ~:

>     TestCase $ assertEqual "for test count," count (testCaseCount t)

> testCaseCountTests :: Test

> testCaseCountTests = TestList [

>   "testCaseCount empty" ~: test (map testCountEmpty emptyTests),

>   testCount suite0 1,

>   testCount suite1 0,

>   testCount suite2 1,

>   testCount suite3 suiteCount

>  ]

> testPaths :: Show n => (n, Test) -> [[Node]] -> Test

> testPaths (num, t) paths =

>   "testCasePaths suite" ++ show num ~:

>     TestCase $ assertEqual "for test paths,"

>                             (map reverse paths) (testCasePaths t)

> testPathsEmpty :: Test -> Test

> testPathsEmpty t = TestCase $ assertEqual "" [] (testCasePaths t)

> testCasePathsTests :: Test

> testCasePathsTests = TestList [

>   "testCasePaths empty" ~: test (map testPathsEmpty emptyTests),

>   testPaths suite0 [[]],

>   testPaths suite1 [],

>   testPaths suite2 [[Label "3"]],

>   testPaths suite3 suitePaths

>  ]

> reportTests :: Test

> reportTests = "reports" ~: expectReports suiteReports suiteCounts suite

> removeLocation :: String -> String

> removeLocation = unlines . filter (not . isInfixOf __FILE__) . lines

> expectText :: Counts -> String -> Test -> Test

> expectText counts1 text1 t = TestCase $ do

>   (counts2, text2) <- runTestText putTextToShowS t

>   assertEqual "for the final counts," counts1 counts2

>   assertEqual "for the failure text output," text1 (removeLocation $ text2 "")

> textTests :: Test

> textTests = test [

>   "lone error" ~:

>     expectText (Counts 1 1 1 0)

>         "### Error:\nuser error (xyz)\nCases: 1  Tried: 1  Errors: 1  Failures: 0\n"

>         (test (do _ <- ioError (userError "xyz"); return ())),

>   "lone failure" ~:

>     expectText (Counts 1 1 0 1)

>         "### Failure:\nxyz\nCases: 1  Tried: 1  Errors: 0  Failures: 1\n"

>         (test (assert "xyz")),

>   "putTextToShowS" ~:

>     expectText suiteCounts suiteOutput suite,

>   "putTextToHandle (file)" ~:

>     let filename = "HUnitTest.tmp"

>         trim = unlines . map (reverse . dropWhile (== ' ') . reverse) . lines

>     in map test

>       [ "show progress = " ++ show flag ~: do

>           handle <- openFile filename WriteMode

>           (counts', _) <- runTestText (putTextToHandle handle flag) suite

>           hClose handle

>           assertEqual "for the final counts," suiteCounts counts'

>           text <- readFile filename

>           let text' = removeLocation $ if flag then trim (terminalAppearance text) else text

>           assertEqual "for the failure text output," suiteOutput text'

>       | flag <- [False, True] ]

>  ]

> showPathTests :: Test

> showPathTests = "showPath" ~: [

>   "empty"  ~: showPath [] ~?= "",

>   ":"      ~: showPath [Label ":", Label "::"] ~?= "\"::\":\":\"",

>   "\"\\\n" ~: showPath [Label "\"\\n\n\""] ~?= "\"\\\"\\\\n\\n\\\"\"",

>   "misc"   ~: showPath [Label "b", ListItem 2, ListItem 3, Label "foo"] ~?=

>                        "foo:3:2:b"

>  ]

> showCountsTests :: Test

> showCountsTests = "showCounts" ~: showCounts (Counts 4 3 2 1) ~?=

>                             "Cases: 4  Tried: 3  Errors: 2  Failures: 1"

> lift :: a -> IO a

> lift a = return a

> assertableTests :: Test

> assertableTests =

>   let assertables x = [

>         (       "", assert             x  , test             (lift x))  ,

>         (    "IO ", assert       (lift x) , test       (lift (lift x))) ,

>         ( "IO IO ", assert (lift (lift x)), test (lift (lift (lift x))))]

>       assertabled l e x =

>         test [ test [ "assert" ~: pre ++ l          ~: expect e $ test $ a,

>                       "test"   ~: pre ++ "IO " ++ l ~: expect e $ t ]

>                | (pre, a, t) <- assertables x ]

>   in "assertable" ~: [

>     assertabled "()"    Succ       (),

>     assertabled "True"  Succ       True,

>     assertabled "False" (Fail "")  False,

>     assertabled "\"\""  Succ       "",

>     assertabled "\"x\"" (Fail "x") "x"

>    ]

> predicableTests :: Test

> predicableTests =

>   let predicables x m = [

>         (       "", assertionPredicate      x  ,     x  @? m,     x  ~? m ),

>         (    "IO ", assertionPredicate   (l x) ,   l x  @? m,   l x  ~? m ),

>         ( "IO IO ", assertionPredicate (l(l x)), l(l x) @? m, l(l x) ~? m )]

>       l x = lift x

>       predicabled lab e m x =

>         test [ test [ "pred" ~: pre ++ lab ~: m ~: expect e $ test $ tst p,

>                       "(@?)" ~: pre ++ lab ~: m ~: expect e $ test $ a,

>                       "(~?)" ~: pre ++ lab ~: m ~: expect e $ t ]

>                                    | (pre, p, a, t) <- predicables x m ]

>        where tst p = p >>= assertBool m

>   in "predicable" ~: [

>     predicabled "True"  Succ           "error" True,

>     predicabled "False" (Fail "error") "error" False,

>     predicabled "True"  Succ           ""      True,

>     predicabled "False" (Fail ""     ) ""      False

>    ]

> compareTests :: Test

> compareTests = test [

>   let succ' = const Succ

>       compare1 :: (String -> Expect) -> Integer -> Integer -> Test

>       compare1 = compare'

>       compare2 :: (String -> Expect)

>                -> (Integer, Char, Double)

>                -> (Integer, Char, Double)

>                -> Test

>       compare2 = compare'

>       compare' f expected actual

>           = test [ "(@=?)" ~: expect e $ test (expected @=? actual),

>                    "(@?=)" ~: expect e $ test (actual   @?= expected),

>                    "(~=?)" ~: expect e $       expected ~=? actual,

>                    "(~?=)" ~: expect e $       actual   ~?= expected ]

>        where e = f $ "expected: " ++ show expected ++

>                      "\n but got: " ++ show actual

>   in test [

>     compare1 succ' 1 1,

>     compare1 Fail 1 2,

>     compare2 succ' (1,'b',3.0) (1,'b',3.0),

>     compare2 Fail (1,'b',3.0) (1,'b',3.1)

>    ]

>  ]

> expectList1 :: Int -> Test -> Test

> expectList1 c =

>   expectReports

>     [ Start (State [ListItem n] (Counts c n 0 0)) | n <- [0..c-1] ]

>                                 (Counts c c 0 0)

> expectList2 :: [Int] -> Test -> Test

> expectList2 cs t =

>   expectReports

>     [ Start (State [ListItem j, ListItem i] (Counts c n 0 0))

>         | ((i,j),n) <- zip coords [0..] ]

>                                             (Counts c c 0 0)

>                    t

>  where coords = [ (i,j) | i <- [0 .. length cs - 1], j <- [0 .. cs!!i - 1] ]

>        c = testCaseCount t

> extendedTestTests :: Test

> extendedTestTests = test [

>   "test idempotent" ~: expect Succ $ test $ test $ test $ ok,

>   "test list 1" ~: expectList1 3 $ test [assert (), assert "", assert True],

>   "test list 2" ~: expectList2 [0, 1, 2] $ test [[], [ok], [ok, ok]]

>  ]