From 960b135a9e20012b08af85d3bb3b17faafe61bf7 Mon Sep 17 00:00:00 2001
From: Sven Eric Panitz <panitz@informatik.fh-wiesbaden.de>
Date: Wed, 20 Nov 2024 10:51:40 +0000
Subject: [PATCH] =?UTF-8?q?Update=20HaskellUnit.hs.=20Doppelescape=20gel?=
 =?UTF-8?q?=C3=B6scht=20und=20Testcases=20erm=C3=B6glicht,=20die=20nicht?=
 =?UTF-8?q?=20das=20Ergebnis=20veraten.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 environments/hs/HaskellUnit.hs | 49 +++++++++++++++++++---------------
 1 file changed, 27 insertions(+), 22 deletions(-)

diff --git a/environments/hs/HaskellUnit.hs b/environments/hs/HaskellUnit.hs
index e5612f8..e628db2 100644
--- a/environments/hs/HaskellUnit.hs
+++ b/environments/hs/HaskellUnit.hs
@@ -4,7 +4,6 @@ import Data.Maybe
 import Data.List
 import System.IO
 
-
 esc '"' = "&quot;"
 esc '\'' = "&apos;"
 esc '&' = "&amp;"
@@ -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 [] = []
-- 
GitLab