blob: 60518450dd1513f55b1bff228037e52976310f45 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
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)
|
