octanemech/src/HUnit/HUnitLang.lhs

   1 HUnitLang98.lhs  --  HUnit language support, generic Haskell 98 variant
   2
   3 Note: The Haskell system you use needs to find this file when looking
   4 for module `HUnitLang`.
   5
   6 $Id: HUnitLang98.lhs,v 1.2 2002/02/14 19:27:56 heringto Exp $
   7
   8 > module HUnitLang
   9 > (
  10 >   Assertion,
  11 >   assertFailure,
  12 >   performTestCase
  13 > )
  14 > where
  15
  16
  17 When adapting this module for other Haskell language systems, change
  18 the imports and the implementations but not the interfaces.
  19
  20
  21
  22 Imports
  23 -------
  24
  25 > import List (isPrefixOf)
  26 > import IO (ioeGetErrorString, try)
  27
  28
  29
  30 Interfaces
  31 ----------
  32
  33 An assertion is an `IO` computation with trivial result.
  34
  35 > type Assertion = IO ()
  36
  37 `assertFailure` signals an assertion failure with a given message.
  38
  39 > assertFailure :: String -> Assertion
  40
  41 `performTestCase` performs a single test case.  The meaning of the
  42 result is as follows:
  43   Nothing               test case success
  44   Just (True,  msg)     test case failure with the given message
  45   Just (False, msg)     test case error with the given message
  46
  47 > performTestCase :: Assertion -> IO (Maybe (Bool, String))
  48
  49
  50 Implementations
  51 ---------------
  52
  53 > hunitPrefix = "HUnit:"
  54
  55 > hugsPrefix  = "IO Error: User error\nReason: "
  56 > nhc98Prefix = "I/O error (user-defined), call to function `userError':\n  "
  57 > -- GHC prepends no prefix to the user-supplied string.
  58
  59 > assertFailure msg = ioError (userError (hunitPrefix ++ msg))
  60
  61 > performTestCase action = do r <- try action
  62 >                             case r of Right () -> return Nothing
  63 >                                       Left  e  -> return (Just (decode e))
  64 >  where
  65 >   decode e = let s0 = ioeGetErrorString e
  66 >                  (_, s1) = dropPrefix hugsPrefix  s0
  67 >                  (_, s2) = dropPrefix nhc98Prefix s1
  68 >              in            dropPrefix hunitPrefix s2
  69 >   dropPrefix pref str = if pref `isPrefixOf` str
  70 >                           then (True, drop (length pref) str)
  71 >                           else (False, str)