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
|
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{- |
Module : Data.GraphViz.Internal.State
Description : Printing and parsing state.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
When printing and parsing Dot code, some items depend on values
that are set earlier.
-}
module Data.GraphViz.Internal.State
( GraphvizStateM(..)
, GraphvizState(..)
, AttributeType(..)
, setAttributeType
, getAttributeType
, initialState
, setDirectedness
, getDirectedness
, setLayerSep
, getLayerSep
, setLayerListSep
, getLayerListSep
, setColorScheme
, getColorScheme
) where
import Data.GraphViz.Attributes.ColorScheme
import Control.Monad.Trans.State (State, gets, modify)
import Text.ParserCombinators.Poly.StateText (Parser, stQuery, stUpdate)
-- -----------------------------------------------------------------------------
class (Monad m) => GraphvizStateM m where
modifyGS :: (GraphvizState -> GraphvizState) -> m ()
getsGS :: (GraphvizState -> a) -> m a
instance GraphvizStateM (State GraphvizState) where
modifyGS = modify
getsGS = gets
instance GraphvizStateM (Parser GraphvizState) where
modifyGS = stUpdate
getsGS = stQuery
data AttributeType = GraphAttribute
| SubGraphAttribute
| ClusterAttribute
| NodeAttribute
| EdgeAttribute
deriving (Eq, Ord, Show, Read)
-- | Several aspects of Dot code are either global or mutable state.
data GraphvizState = GS { parseStrictly :: !Bool
-- ^ If 'False', allow fallbacks for
-- attributes that don't match known
-- specification when parsing.
, directedEdges :: !Bool
, layerSep :: [Char]
, layerListSep :: [Char]
, attributeType :: !AttributeType
, graphColor :: !ColorScheme
, clusterColor :: !ColorScheme
, nodeColor :: !ColorScheme
, edgeColor :: !ColorScheme
}
deriving (Eq, Ord, Show, Read)
initialState :: GraphvizState
initialState = GS { parseStrictly = True
, directedEdges = True
, layerSep = defLayerSep
, layerListSep = defLayerListSep
, attributeType = GraphAttribute
, graphColor = X11
, clusterColor = X11
, nodeColor = X11
, edgeColor = X11
}
setDirectedness :: (GraphvizStateM m) => Bool -> m ()
setDirectedness d = modifyGS (\ gs -> gs { directedEdges = d } )
getDirectedness :: (GraphvizStateM m) => m Bool
getDirectedness = getsGS directedEdges
setAttributeType :: (GraphvizStateM m) => AttributeType -> m ()
setAttributeType tp = modifyGS $ \ gs -> gs { attributeType = tp }
getAttributeType :: (GraphvizStateM m) => m AttributeType
getAttributeType = getsGS attributeType
setLayerSep :: (GraphvizStateM m) => [Char] -> m ()
setLayerSep sep = modifyGS (\ gs -> gs { layerSep = sep } )
getLayerSep :: (GraphvizStateM m) => m [Char]
getLayerSep = getsGS layerSep
setLayerListSep :: (GraphvizStateM m) => [Char] -> m ()
setLayerListSep sep = modifyGS (\ gs -> gs { layerListSep = sep } )
getLayerListSep :: (GraphvizStateM m) => m [Char]
getLayerListSep = getsGS layerListSep
setColorScheme :: (GraphvizStateM m) => ColorScheme -> m ()
setColorScheme cs = do tp <- getsGS attributeType
modifyGS $ \gs -> case tp of
GraphAttribute -> gs { graphColor = cs }
-- subgraphs don't have specified scheme
SubGraphAttribute -> gs { graphColor = cs }
ClusterAttribute -> gs { clusterColor = cs }
NodeAttribute -> gs { nodeColor = cs }
EdgeAttribute -> gs { edgeColor = cs }
getColorScheme :: (GraphvizStateM m) => m ColorScheme
getColorScheme = do tp <- getsGS attributeType
getsGS $ case tp of
GraphAttribute -> graphColor
-- subgraphs don't have specified scheme
SubGraphAttribute -> graphColor
ClusterAttribute -> clusterColor
NodeAttribute -> nodeColor
EdgeAttribute -> edgeColor
-- | The default separators for 'LayerSep'.
defLayerSep :: [Char]
defLayerSep = [' ', ':', '\t']
-- | The default separators for 'LayerListSep'.
defLayerListSep :: [Char]
defLayerListSep = [',']
|
