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/ppdot.hs | 72 +++++++++++++++++++++++++++++++
 1 file changed, 72 insertions(+)
 create mode 100644 Haskell-book/24/language-dot/src/ppdot.hs

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

diff --git a/Haskell-book/24/language-dot/src/ppdot.hs b/Haskell-book/24/language-dot/src/ppdot.hs
new file mode 100644
index 0000000..6051845
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/ppdot.hs
@@ -0,0 +1,72 @@
+module Main (main) where
+
+import Control.Exception   (IOException, try)
+import Control.Monad.Error (ErrorT(..), MonadError(..))
+import System.Environment  (getArgs, getProgName)
+import System.Exit         (exitFailure, exitSuccess)
+import System.IO           (hPutStrLn, stderr)
+
+import Language.Dot (parseDot, renderDot)
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+main :: IO ()
+main =
+    getArgs >>= run
+
+run :: [String] -> IO ()
+run args =
+    case args of
+      [fp] -> renderDotFile fp
+      []   -> displayUsage >> exitSuccess
+      _    -> displayUsage >> exitFailure
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+renderDotFile :: FilePath -> IO ()
+renderDotFile fp =
+    runErrorT (renderDotFileET fp) >>= either exitError putStrLn
+
+renderDotFileET :: FilePath -> ErrorT String IO String
+renderDotFileET fp = do
+    contents <- readFile fp `liftCatch` show
+    graph    <- parseDot fp contents `liftEither` show
+    return $ renderDot graph
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+displayUsage :: IO ()
+displayUsage = do
+    programName <- getProgName
+    ePutStrLns
+      [ programName ++ ": Pretty-print a Graphviz DOT file."
+      , unwords ["Usage:", programName, "FILE"]
+      ]
+
+exitError :: String -> IO ()
+exitError e = do
+    displayUsage
+    ePutStrLn ""
+    let el = lines e
+    if length el == 1
+      then ePutStrLn  ("ERROR: " ++ e)
+      else ePutStrLns ("ERROR:" : indent el)
+    exitFailure
+  where
+    indent = map ("  "++)
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+liftCatch :: IO a -> (IOException -> e) -> ErrorT e IO a
+liftCatch a f = ErrorT $ fmap (either (Left . f) Right) (try a)
+
+liftEither :: (MonadError e m) => Either l r -> (l -> e) -> m r
+liftEither e f = either (throwError . f) return e
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+ePutStrLn :: String -> IO ()
+ePutStrLn = hPutStrLn stderr
+
+ePutStrLns :: [String] -> IO ()
+ePutStrLns = mapM_ (hPutStrLn stderr)
-- 
cgit v1.2.3