blob: 84a4c0c092c4fb58334c0aefb6cc0b033fcc8ef4 (
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
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
|
module Language.Dot.Pretty
( prettyPrintDot
, renderDot
, PP(..)
)
where
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
import Numeric
import Text.PrettyPrint
import Language.Dot.Syntax
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
prettyPrintDot :: Graph -> Doc
prettyPrintDot = pp
renderDot :: Graph -> String
renderDot = render . pp
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
class PP a where
pp :: a -> Doc
instance (PP a) => PP (Maybe a) where
pp (Just v) = pp v
pp Nothing = empty
instance PP Graph where
pp (Graph s d mi ss) = pp s <+> pp d <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace
instance PP GraphStrictness where
pp StrictGraph = text "strict"
pp UnstrictGraph = empty
instance PP GraphDirectedness where
pp DirectedGraph = text "digraph"
pp UndirectedGraph = text "graph"
instance PP Id where
pp (NameId v) = text v
pp (StringId v) = doubleQuotes (text v)
pp (IntegerId v) = integer v
pp (FloatId v) = ffloat v
pp (XmlId v) = langle <> pp v <> rangle
instance PP Statement where
pp (NodeStatement ni as) = pp ni <+> if not (null as) then brackets (hsep' as) else empty
pp (EdgeStatement es as) = hsep' es <+> if not (null as) then brackets (hsep' as) else empty
pp (AttributeStatement t as) = pp t <+> brackets (hsep' as)
pp (AssignmentStatement i0 i1) = pp i0 <> equals <> pp i1
pp (SubgraphStatement s) = pp s
instance PP AttributeStatementType where
pp GraphAttributeStatement = text "graph"
pp NodeAttributeStatement = text "node"
pp EdgeAttributeStatement = text "edge"
instance PP Attribute where
pp (AttributeSetTrue i) = pp i
pp (AttributeSetValue i0 i1) = pp i0 <> equals <> pp i1
instance PP NodeId where
pp (NodeId i mp) = pp i <> pp mp
instance PP Port where
pp (PortI i mc) = colon <> pp i <> maybe empty ((colon <>) . pp) mc
pp (PortC c) = colon <> pp c
instance PP Compass where
pp CompassN = text "n"
pp CompassE = text "e"
pp CompassS = text "s"
pp CompassW = text "w"
pp CompassNE = text "ne"
pp CompassNW = text "nw"
pp CompassSE = text "se"
pp CompassSW = text "sw"
instance PP Subgraph where
pp (NewSubgraph mi ss) = text "subgraph" <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace
pp (SubgraphRef i) = text "subgraph" <+> pp i
instance PP Entity where
pp (ENodeId et ni) = pp et <+> pp ni
pp (ESubgraph et sg) = pp et <+> pp sg
instance PP EdgeType where
pp NoEdge = empty
pp DirectedEdge = text "->"
pp UndirectedEdge = text "--"
instance PP Xml where
pp (XmlEmptyTag n as) = langle <> pp n <+> hsep' as <> slash <> rangle
pp (XmlTag n as xs) = langle <> pp n <+> hsep' as <> rangle <> hcat' xs <> langle <> slash <> pp n <> rangle
pp (XmlText t) = text t
instance PP XmlName where
pp (XmlName n) = text n
instance PP XmlAttribute where
pp (XmlAttribute n v) = pp n <> equals <> pp v
instance PP XmlAttributeValue where
pp (XmlAttributeValue v) = doubleQuotes (text v)
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
indent :: Doc -> Doc
indent = nest 2
hcat' :: (PP a) => [a] -> Doc
hcat' = hcat . map pp
hsep' :: (PP a) => [a] -> Doc
hsep' = hsep . map pp
vcat' :: (PP a) => [a] -> Doc
vcat' = vcat . map pp
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
langle :: Doc
rangle :: Doc
slash :: Doc
langle = char '<'
rangle = char '>'
slash = char '/'
ffloat :: Float -> Doc
ffloat v = text (showFFloat Nothing v "")
|
