Update HaskellUnit.hs. Doppelescape gelöscht und Testcases ermöglicht, die...

Update HaskellUnit.hs. Doppelescape gelöscht und Testcases ermöglicht, die nicht das Ergebnis veraten.

environments/hs/HaskellUnit.hs

@@ -4,7 +4,6 @@ import Data.Maybe
 import Data.List
 import System.IO
 
-
 esc '"' = """
 esc '\'' = "'"
 esc '&' = "&"
@@ -14,29 +13,14 @@ esc c = [c]
 
 xmlEsc = concat.map esc
 
-
 runTests tests = do
   putStrLn "<?xml version=\"1.0\" ?>"
   putStrLn "<testsuite>"
   xs <- sequence tests
   putStrLn "</testsuite>"
 
-
-compareResult expected actual = do
-  catch
-    (if (expected == actual)
-      then return Nothing
-      else return (Just (xmlEsc ("expected:&lt;"++show expected++"&gt; but was:&lt;"++show actual++"&gt;"))))
-    (\e->return (Just (replace "\n" " "("Exception in evaluation: "++ (show (e :: SomeException))))))
-
-replace [] _ _ = error "Extra.replace, first argument cannot be empty"
-replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs
-replace from to (x:xs) = x : replace from to xs
-replace from to [] = []
-
-
-testcase name msg expected actual  = do
-    res <- compareResult expected actual
+genericTestcase compareFunction  name msg expected actual  = do
+    res <- compareFunction expected actual
     maybe
       (do
           putStrLn ("  <testcase name=\""++name++"\">")
@@ -46,7 +30,6 @@ testcase name msg expected actual  = do
           return True)
       (\failMessage -> do
           putStrLn ("  <testcase name=\""++name++"\">")
-          --let failMessage = "expected:&lt;"++show expected++"&gt; but was:&lt;"++show actual++"&gt;"
           putStrLn ("    <failure message=\""++failMessage++"\">")
           putStrLn (msg++": "++failMessage)
           putStrLn "    </failure>"
@@ -54,6 +37,28 @@ testcase name msg expected actual  = do
           return False)
       res
 
-iotestcase name msg expected actualIO  = do
-  actual <- actualIO
-  testcase name msg expected actual
+testcase :: (Eq a, Show a) => [Char] -> [Char] -> a -> a -> IO Bool
+testcase  = genericTestcase compareResult
+
+valuetestcase :: (Eq a, Show a) => [Char] -> [Char] -> a -> a -> IO Bool
+valuetestcase = genericTestcase compareValueResult 
+
+compareValueResult expected actual = do
+  catch
+    (if (expected == actual)
+      then return Nothing
+      else return (Just (xmlEsc ("<"++show actual++">"++" is not the expected solution."))))
+    (\e->return (Just (replace "\n" " "("Exception in evaluation: "++ (show (e :: SomeException))))))
+
+
+compareResult expected actual = do
+  catch
+    (if (expected == actual)
+      then return Nothing
+      else return (Just (xmlEsc ("expected:<"++show expected++"> but was:<"++show actual++">"))))
+    (\e->return (Just (replace "\n" " "("Exception in evaluation: "++ (show (e :: SomeException))))))
+
+replace [] _ _ = error "Extra.replace, first argument cannot be empty"
+replace from to xs | Just xs <- stripPrefix from xs = to ++ replace from to xs
+replace from to (x:xs) = x : replace from to xs
+replace from to [] = []