Ticket #476: Lang.lhs.2.patch

File Lang.lhs.2.patch, 2.4 KB (added by stefanheimann, 8 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