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
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
module ShowDotGraph
( DotGraph, dgraph, ugraph, Node(..), Edge(..)
, viewDotGraph, showDotGraph, getDotViewCmd, setDotViewCmd )
where
import Char ( isAlphaNum )
import Distribution ( rcFileName, getRcVar )
import IO
import IOExts
import List ( intercalate, last )
import PropertyFile ( updatePropertyFile )
data DotGraph = DGraph String [Node] [Edge]
| UGraph String [Node] [Edge]
dgraph :: String -> [Node] -> [Edge] -> DotGraph
dgraph name nodes edges = DGraph name nodes edges
ugraph :: String -> [Node] -> [Edge] -> DotGraph
ugraph name nodes edges = UGraph name nodes edges
data Node = Node String [(String,String)]
data Edge = Edge String String [(String,String)]
viewDotGraph :: DotGraph -> IO ()
viewDotGraph = viewDot . showDotGraph
showDotGraph :: DotGraph -> String
showDotGraph (DGraph name nodes edges) =
"digraph \"" ++ name ++ "\"" ++ graphbody2dot True nodes edges
showDotGraph (UGraph name nodes edges) =
"graph \"" ++ name ++ "\"" ++ graphbody2dot False nodes edges
graphbody2dot :: Bool -> [Node] -> [Edge] -> String
graphbody2dot directed nodes edges =
"{\n" ++ concatMap node2dot nodes ++
concatMap (edge2dot directed) edges ++ "}\n"
node2dot :: Node -> String
node2dot (Node nname attrs) =
showDotID nname ++ showDotAttrs attrs ++ ";\n"
edge2dot :: Bool -> Edge -> String
edge2dot directed (Edge i j attrs) =
showDotID i ++ edgeOp ++ showDotID j ++ showDotAttrs attrs ++ ";\n"
where
edgeOp = if directed then " -> " else " -- "
showDotAttrs :: [(String, String)] -> String
showDotAttrs attrs =
if null attrs then ""
else '[' : intercalate "," (map showDotAttr attrs) ++ "]"
showDotAttr :: (String,String) -> String
showDotAttr (name,value)
| name == "label" && not (null value) && head value == '<' && last value == '>'
= "label=" ++ value
| otherwise
= name ++ "=\"" ++ value ++ "\""
showDotID :: String -> String
showDotID s | all isAlphaNum s = s
| otherwise = '"' : concatMap escapeDQ s ++ "\""
where
escapeDQ c = if c=='"' then "\\\"" else [c]
viewDot :: String -> IO ()
viewDot dottxt = do
dotview <- getDotViewCmd
dotstr <- connectToCommand dotview
hPutStr dotstr dottxt
hClose dotstr
getDotViewCmd :: IO String
getDotViewCmd = getRcVar "dotviewcommand" >>= return . maybe "" id
setDotViewCmd :: String -> IO ()
setDotViewCmd dvcmd = do
rcfile <- rcFileName
updatePropertyFile rcfile "dotviewcommand" dvcmd
|