Ticket #476: Lang.lhs.2.patch

File Lang.lhs.2.patch, 2.4 KB (added by stefanheimann, 10 years ago)
  • Lang.lhs

    RCS file: /cvs/fptools/libraries/HUnit/Test/HUnit/Lang.lhs,v
    retrieving revision 1.3
    diff -u -r1.3 Lang.lhs
     
    1919
    2020> import Data.List (isPrefixOf)
    2121#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
    22 > import Control.Exception (try)
     22> import Data.Dynamic
     23> import Control.Exception as E         ( throwDyn, try, Exception(..) )
    2324#else
    2425> import System.IO.Error (ioeGetErrorString, try)
    2526#endif
     
    4950Implementations
    5051---------------
    5152
     53#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
     54> data HUnitFailure = HUnitFailure String
     55>
     56> hunitFailureTc :: TyCon
     57> hunitFailureTc = mkTyCon "HUnitFailure"
     58> {-# NOINLINE hunitFailureTc #-}
     59>
     60> instance Typeable HUnitFailure where
     61>     typeOf _ = mkTyConApp hunitFailureTc []
     62
     63> assertFailure msg = E.throwDyn (HUnitFailure msg)
     64
     65> performTestCase action =
     66>     do r <- E.try action
     67>        case r of
     68>          Right () -> return Nothing
     69>          Left e@(E.DynException dyn) ->
     70>              case fromDynamic dyn of
     71>                Just (HUnitFailure msg) -> return $ Just (True, msg)
     72>                Nothing                 -> return $ Just (False, show e)
     73>          Left e -> return $ Just (False, show e)
     74#else
    5275> hunitPrefix = "HUnit:"
    5376
    54 > hugsPrefix  = "IO Error: User error\nReason: "
    5577> nhc98Prefix = "I/O error (user-defined), call to function `userError':\n  "
    56 > -- GHC prepends no prefix to the user-supplied string.
    5778
    5879> assertFailure msg = ioError (userError (hunitPrefix ++ msg))
    5980
     
    6182>                             case r of Right () -> return Nothing
    6283>                                       Left  e  -> return (Just (decode e))
    6384>  where
    64 #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
    65 >   decode e = let s0 = show e
    66 #else
    6785>   decode e = let s0 = ioeGetErrorString e
    68 #endif
    69 >                  (_, s1) = dropPrefix hugsPrefix  s0
    70 >                  (_, s2) = dropPrefix nhc98Prefix s1
    71 >              in            dropPrefix hunitPrefix s2
     86>                  (_, s1) = dropPrefix nhc98Prefix s0
     87>              in            dropPrefix hunitPrefix s1
    7288>   dropPrefix pref str = if pref `isPrefixOf` str
    7389>                           then (True, drop (length pref) str)
    7490>                           else (False, str)
     91#endif