From 98329e0a3dd4f78b5d815ac3896272ec70904901 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Thu, 11 Dec 2025 10:28:11 +0100
Subject: Add remaining haskell book exercises

---
 Haskell-book/24/language-dot/src/test.hs | 120 +++++++++++++++++++++++++++++++
 1 file changed, 120 insertions(+)
 create mode 100644 Haskell-book/24/language-dot/src/test.hs

(limited to 'Haskell-book/24/language-dot/src/test.hs')

diff --git a/Haskell-book/24/language-dot/src/test.hs b/Haskell-book/24/language-dot/src/test.hs
new file mode 100644
index 0000000..2fa4e0b
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/test.hs
@@ -0,0 +1,120 @@
+module Main (main) where
+
+import Control.Monad (unless)
+import Data.Char     (toLower, toUpper)
+
+import Text.Parsec
+import Text.Parsec.String
+
+import Language.Dot.Parser
+import Language.Dot.Syntax
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+main :: IO ()
+main = do
+    testParser "parsePort"      parsePort      parsePortTests
+    testParser "parseCompass"   parseCompass   parseCompassTests
+    testParser "parseAttribute" parseAttribute parseAttributeTests
+    testParser "parseId"        parseId        parseIdTests
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+parsePortTests :: [(String, Port)]
+parsePortTests =
+    [ ( ":\"x\""          , PortI (StringId  "x"       ) Nothing          )
+    , ( ":\"\\t\\\"\":nw" , PortI (StringId  "\\t\""   ) (Just CompassNW) )
+    , ( ":-.0004"         , PortI (FloatId   (-0.0004) ) Nothing          )
+    , ( ":-1.23:sE"       , PortI (FloatId   (-1.23)   ) (Just CompassSE) )
+    , ( ":123"            , PortI (IntegerId 123       ) Nothing          )
+    , ( ":123:NE"         , PortI (IntegerId 123       ) (Just CompassNE) )
+    , ( ":__2xYz"         , PortI (NameId    "__2xYz"  ) Nothing          )
+    , ( ":__2xYz:S"       , PortI (NameId    "__2xYz"  ) (Just CompassS)  )
+    , ( ":n"              , PortC CompassN  )
+    , ( ":SE"             , PortC CompassSE )
+    ]
+
+parseCompassTests :: [(String, Compass)]
+parseCompassTests =
+    concat
+      [ [ (t, CompassN)  | t <- allCaps "n"  ]
+      , [ (t, CompassE)  | t <- allCaps "e"  ]
+      , [ (t, CompassS)  | t <- allCaps "s"  ]
+      , [ (t, CompassW)  | t <- allCaps "w"  ]
+      , [ (t, CompassNE) | t <- allCaps "ne" ]
+      , [ (t, CompassNW) | t <- allCaps "nw" ]
+      , [ (t, CompassSE) | t <- allCaps "se" ]
+      , [ (t, CompassSW) | t <- allCaps "sw" ]
+      ]
+
+parseAttributeTests :: [(String, Attribute)]
+parseAttributeTests =
+    [ ( "a"                      , AttributeSetTrue  (NameId "a")                           )
+    , ( "a=b"                    , AttributeSetValue (NameId "a")       (NameId "b")        )
+    , ( "-.003\t=\r\n  _xYz123_" , AttributeSetValue (FloatId (-0.003)) (NameId "_xYz123_") )
+    , ( "\"\\t\\\"\"  =-123"     , AttributeSetValue (StringId "\\t\"") (IntegerId (-123))  )
+    ]
+
+parseIdTests :: [(String, Id)]
+parseIdTests =
+    [ ( "a"             , NameId    "a"         )
+    , ( "A1"            , NameId    "A1"        )
+    , ( "_2X"           , NameId    "_2X"       )
+    , ( "\"\""          , StringId  ""          )
+    , ( "\"\\t\\r\\n\"" , StringId  "\\t\\r\\n" )
+    , ( ".0"            , FloatId   0.0         )
+    , ( ".123"          , FloatId   0.123       )
+    , ( "+.999"         , FloatId   0.999       )
+    , ( "-.001"         , FloatId   (-0.001)    )
+    , ( "+.001"         , FloatId   0.001       )
+    , ( "0.0"           , FloatId   0.0         )
+    , ( "1.2"           , FloatId   1.2         )
+    , ( "123.456"       , FloatId   123.456     )
+    , ( "0"             , IntegerId 0           )
+    , ( "+0"            , IntegerId 0           )
+    , ( "-0"            , IntegerId 0           )
+    , ( "123"           , IntegerId 123         )
+    , ( "-123"          , IntegerId (-123)      )
+    ]
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+testParser :: (Eq a, Show a) => String -> Parser a -> [(String, a)] -> IO ()
+testParser name parser tests =
+    help tests [] (0 :: Int) (0 :: Int)
+  where
+    help [] es np nf = do
+        putStrLn $ name ++ ": " ++ show np ++ " passed, " ++ show nf ++ " failed"
+        mapM_ (putStrLn . ("  "++)) (reverse es)
+        unless (null es) (putStrLn "")
+    help ((i,o):ts) es np nf =
+        case parse' parser i of
+          Left  _ -> help ts (makeFailureMessage name i o : es) np (succ nf)
+          Right v ->
+            if v /= o
+              then help ts (makeFailureMessage' name i o v : es) np (succ nf)
+              else help ts es (succ np) nf
+
+makeFailureMessage :: (Show a) => String -> String -> a -> String
+makeFailureMessage name i o =
+    "(" ++ name ++ " " ++ show i ++ ")" ++
+    " should have returned " ++ "(" ++ show o ++ ")"
+
+makeFailureMessage' :: (Show a) => String -> String -> a -> a -> String
+makeFailureMessage' name i o v =
+    "(" ++ name ++ " " ++ show i ++ ")" ++
+    " returned "  ++ "(" ++ show v ++ ")" ++
+    ", expected " ++ "(" ++ show o ++ ")"
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+parse' :: Parser a -> String -> Either ParseError a
+parse' p = parse p ""
+
+allCaps :: String -> [String]
+allCaps []     = [[]]
+allCaps (c:cs) =
+    concatMap (\t -> [l:t, u:t]) (allCaps cs)
+  where
+    l = toLower c
+    u = toUpper c
-- 
cgit v1.2.3