diff options
| author | Eugen Wissner <belka@caraus.de> | 2025-12-11 10:28:11 +0100 |
|---|---|---|
| committer | Eugen Wissner <belka@caraus.de> | 2025-12-11 10:28:11 +0100 |
| commit | 98329e0a3dd4f78b5d815ac3896272ec70904901 (patch) | |
| tree | 80f9c56cfe2ac20232358f236d32e84bd683be1b /Haskell-book/24/language-dot/src/ppdot.hs | |
| parent | 3624c712d72d246f21d4e710cec7c11e052e0326 (diff) | |
| download | book-exercises-98329e0a3dd4f78b5d815ac3896272ec70904901.tar.gz | |
Add remaining haskell book exercises
Diffstat (limited to 'Haskell-book/24/language-dot/src/ppdot.hs')
| -rw-r--r-- | Haskell-book/24/language-dot/src/ppdot.hs | 72 |
1 files changed, 72 insertions, 0 deletions
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)
|