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
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
|
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{- |
Module : Data.GraphViz.Types.Generalised.
Description : Alternate definition of the Graphviz types.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
The generalised Dot representation most closely matches the
implementation of actual Dot code, as it places no restrictions on
ordering of elements, etc. As such it should be able to parse any
existing Dot code (taking into account the parsing
limitations/assumptions).
The sample graph could be implemented (this is actually a prettied
version of parsing in the Dot code) as:
> DotGraph { strictGraph = False
> , directedGraph = True
> , graphID = Just (Str "G")
> , graphStatements = Seq.fromList [ SG $ DotSG { isCluster = True
> , subGraphID = Just (Int 0)
> , subGraphStmts = Seq.fromList [ GA $ GraphAttrs [style filled]
> , GA $ GraphAttrs [color LightGray]
> , GA $ NodeAttrs [style filled, color White]
> , DE $ DotEdge "a0" "a1" []
> , DE $ DotEdge "a1" "a2" []
> , DE $ DotEdge "a2" "a3" []
> , GA $ GraphAttrs [textLabel "process #1"]]}
> , SG $ DotSG { isCluster = True
> , subGraphID = Just (Int 1)
> , subGraphStmts = fromList [ GA $ NodeAttrs [style filled]
> , DE $ DotEdge "b0" "b1" []
> , DE $ DotEdge "b1" "b2" []
> , DE $ DotEdge "b2" "b3" []
> , GA $ GraphAttrs [textLabel "process #2"]
> , GA $ GraphAttrs [color Blue]]}
> , DE $ DotEdge "start" "a0" []
> , DE $ DotEdge "start" "b0" []
> , DE $ DotEdge "a1" "b3" []
> , DE $ DotEdge "b2" "a3" []
> , DE $ DotEdge "a3" "a0" []
> , DE $ DotEdge "a3" "end" []
> , DE $ DotEdge "b3" "end" []
> , DN $ DotNode "start" [shape MDiamond]
> , DN $ DotNode "end" [shape MSquare]]}
-}
module Data.GraphViz.Types.Generalised
( DotGraph(..)
, FromGeneralisedDot (..)
-- * Sub-components of a @DotGraph@.
, DotStatements
, DotStatement(..)
, DotSubGraph(..)
-- * Re-exported from @Data.GraphViz.Types@.
, GraphID(..)
, GlobalAttributes(..)
, DotNode(..)
, DotEdge(..)
) where
import Data.GraphViz.Algorithms (canonicalise)
import Data.GraphViz.Internal.State (AttributeType (..))
import Data.GraphViz.Internal.Util (bool)
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.Types
import qualified Data.GraphViz.Types.Canonical as C
import Data.GraphViz.Types.Internal.Common
import Data.GraphViz.Types.State
import Control.Arrow ((&&&))
import Control.Monad.Trans.State (evalState, execState, get, modify,
put)
import qualified Data.Foldable as F
import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import qualified Data.Traversable as T
-- -----------------------------------------------------------------------------
-- | The internal representation of a generalised graph in Dot form.
data DotGraph n = DotGraph { -- | If 'True', no multiple edges are drawn.
strictGraph :: Bool
, directedGraph :: Bool
, graphID :: Maybe GraphID
, graphStatements :: DotStatements n
}
deriving (Eq, Ord, Show, Read)
instance (Ord n) => DotRepr DotGraph n where
fromCanonical = generaliseDotGraph
getID = graphID
setID i g = g { graphID = Just i }
graphIsDirected = directedGraph
setIsDirected d g = g { directedGraph = d }
graphIsStrict = strictGraph
setStrictness s g = g { strictGraph = s }
mapDotGraph = fmap
graphStructureInformation = getGraphInfo
. statementStructure . graphStatements
nodeInformation wGlobal = getNodeLookup wGlobal
. statementNodes . graphStatements
edgeInformation wGlobal = getDotEdges wGlobal
. statementEdges . graphStatements
unAnonymise = renumber
instance (Ord n, PrintDot n) => PrintDotRepr DotGraph n
instance (Ord n, ParseDot n) => ParseDotRepr DotGraph n
instance (Ord n, PrintDot n, ParseDot n) => PPDotRepr DotGraph n
instance (PrintDot n) => PrintDot (DotGraph n) where
unqtDot = printStmtBased printGraphID' (const GraphAttribute)
graphStatements printGStmts
where
printGraphID' = printGraphID strictGraph directedGraph graphID
instance (ParseDot n) => ParseDot (DotGraph n) where
parseUnqt = parseGraphID DotGraph
<*> parseBracesBased GraphAttribute parseGStmts
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
("Not a valid generalised DotGraph\n\t"++)
-- | Assumed to be an injective mapping function.
instance Functor DotGraph where
fmap f g = g { graphStatements = (fmap . fmap) f $ graphStatements g }
-- | Convert a 'DotGraph' to a 'DotGraph', keeping the same order of
-- statements.
generaliseDotGraph :: C.DotGraph n -> DotGraph n
generaliseDotGraph dg = DotGraph { strictGraph = C.strictGraph dg
, directedGraph = C.directedGraph dg
, graphID = C.graphID dg
, graphStatements = generaliseStatements
$ C.graphStatements dg
}
-- -----------------------------------------------------------------------------
-- | This class is useful for being able to parse in a dot graph as a
-- generalised one, and then convert it to your preferred
-- representation.
--
-- This can be seen as a semi-inverse of 'fromCanonical'.
class (DotRepr dg n) => FromGeneralisedDot dg n where
fromGeneralised :: DotGraph n -> dg n
instance (Ord n) => FromGeneralisedDot C.DotGraph n where
fromGeneralised = canonicalise
instance (Ord n) => FromGeneralisedDot DotGraph n where
fromGeneralised = id
-- -----------------------------------------------------------------------------
type DotStatements n = Seq (DotStatement n)
printGStmts :: (PrintDot n) => DotStatements n -> DotCode
printGStmts = toDot . F.toList
parseGStmts :: (ParseDot n) => Parse (DotStatements n)
parseGStmts = (Seq.fromList <$> parse)
`adjustErr`
("Not a valid generalised DotStatements\n\t"++)
statementStructure :: DotStatements n -> GraphState ()
statementStructure = F.mapM_ stmtStructure
statementNodes :: (Ord n) => DotStatements n -> NodeState n ()
statementNodes = F.mapM_ stmtNodes
statementEdges :: DotStatements n -> EdgeState n ()
statementEdges = F.mapM_ stmtEdges
generaliseStatements :: C.DotStatements n -> DotStatements n
generaliseStatements stmts = atts >< sgs >< ns >< es
where
atts = Seq.fromList . map GA $ C.attrStmts stmts
sgs = Seq.fromList . map (SG . generaliseSubGraph) $ C.subGraphs stmts
ns = Seq.fromList . map DN $ C.nodeStmts stmts
es = Seq.fromList . map DE $ C.edgeStmts stmts
data DotStatement n = GA GlobalAttributes
| SG (DotSubGraph n)
| DN (DotNode n)
| DE (DotEdge n)
deriving (Eq, Ord, Show, Read)
instance (PrintDot n) => PrintDot (DotStatement n) where
unqtDot (GA ga) = unqtDot ga
unqtDot (SG sg) = unqtDot sg
unqtDot (DN dn) = unqtDot dn
unqtDot (DE de) = unqtDot de
unqtListToDot = vcat . mapM unqtDot
listToDot = unqtListToDot
instance (ParseDot n) => ParseDot (DotStatement n) where
parseUnqt = oneOf [ GA <$> parseUnqt
, SG <$> parseUnqt
, DN <$> parseUnqt
, DE <$> parseUnqt
]
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
("Not a valid statement\n\t"++)
parseUnqtList = fmap concat . wrapWhitespace
$ parseStatements p
where
-- Have to do something special here because of "a -> b -> c"
-- syntax for edges.
p = fmap (map DE) parseEdgeLine
`onFail`
fmap (:[]) parse
parseList = parseUnqtList
instance Functor DotStatement where
fmap _ (GA ga) = GA ga -- Have to re-make this to make the type checker happy.
fmap f (SG sg) = SG $ fmap f sg
fmap f (DN dn) = DN $ fmap f dn
fmap f (DE de) = DE $ fmap f de
stmtStructure :: DotStatement n -> GraphState ()
stmtStructure (GA ga) = addGraphGlobals ga
stmtStructure (SG sg) = withSubGraphID addSubGraph statementStructure sg
stmtStructure _ = return ()
stmtNodes :: (Ord n) => DotStatement n -> NodeState n ()
stmtNodes (GA ga) = addNodeGlobals ga
stmtNodes (SG sg) = withSubGraphID recursiveCall statementNodes sg
stmtNodes (DN dn) = addNode dn
stmtNodes (DE de) = addEdgeNodes de
stmtEdges :: DotStatement n -> EdgeState n ()
stmtEdges (GA ga) = addEdgeGlobals ga
stmtEdges (SG sg) = withSubGraphID recursiveCall statementEdges sg
stmtEdges (DE de) = addEdge de
stmtEdges _ = return ()
-- -----------------------------------------------------------------------------
data DotSubGraph n = DotSG { isCluster :: Bool
, subGraphID :: Maybe GraphID
, subGraphStmts :: DotStatements n
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot n) => PrintDot (DotSubGraph n) where
unqtDot = printStmtBased printSubGraphID' subGraphAttrType
subGraphStmts printGStmts
unqtListToDot = printStmtBasedList printSubGraphID' subGraphAttrType
subGraphStmts printGStmts
listToDot = unqtListToDot
subGraphAttrType :: DotSubGraph n -> AttributeType
subGraphAttrType = bool SubGraphAttribute ClusterAttribute . isCluster
printSubGraphID' :: DotSubGraph n -> DotCode
printSubGraphID' = printSubGraphID (isCluster &&& subGraphID)
instance (ParseDot n) => ParseDot (DotSubGraph n) where
parseUnqt = parseSubGraph DotSG parseGStmts
`onFail`
-- Take anonymous DotSubGraphs into account
fmap (DotSG False Nothing)
(parseBracesBased SubGraphAttribute parseGStmts)
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
("Not a valid Sub Graph\n\t"++)
parseUnqtList = sepBy (whitespace *> parseUnqt) newline'
parseList = parseUnqtList
instance Functor DotSubGraph where
fmap f sg = sg { subGraphStmts = (fmap . fmap) f $ subGraphStmts sg }
generaliseSubGraph :: C.DotSubGraph n -> DotSubGraph n
generaliseSubGraph (C.DotSG isC mID stmts) = DotSG { isCluster = isC
, subGraphID = mID
, subGraphStmts = stmts'
}
where
stmts' = generaliseStatements stmts
withSubGraphID :: (Maybe (Maybe GraphID) -> b -> a)
-> (DotStatements n -> b) -> DotSubGraph n -> a
withSubGraphID f g sg = f mid . g $ subGraphStmts sg
where
mid = bool Nothing (Just $ subGraphID sg) $ isCluster sg
renumber :: DotGraph n -> DotGraph n
renumber dg = dg { graphStatements = newStmts }
where
startN = succ $ maxSGInt dg
newStmts = evalState (stsRe $ graphStatements dg) startN
stsRe = T.mapM stRe
stRe (SG sg) = SG <$> sgRe sg
stRe stmt = pure stmt
sgRe sg = do sgid' <- case subGraphID sg of
Nothing -> do n <- get
put $ succ n
return . Just . Num $ Int n
sgid -> return sgid
stmts' <- stsRe $ subGraphStmts sg
return $ sg { subGraphID = sgid'
, subGraphStmts = stmts'
}
maxSGInt :: DotGraph n -> Int
maxSGInt dg = execState (stsInt $ graphStatements dg)
. (`check` 0)
$ graphID dg
where
check = maybe id max . (numericValue =<<)
stsInt = F.mapM_ stInt
stInt (SG sg) = sgInt sg
stInt _ = return ()
sgInt sg = do modify (check $ subGraphID sg)
stsInt $ subGraphStmts sg
|
