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
|
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
{- |
Module : Data.GraphViz.Attributes.Arrows
Description : Arrow types
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
-}
module Data.GraphViz.Attributes.Arrows where
import Data.GraphViz.Internal.Util (bool)
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.Maybe (isJust)
-- -----------------------------------------------------------------------------
-- | /Dot/ has a basic grammar of arrow shapes which allows usage of
-- up to 1,544,761 different shapes from 9 different basic
-- 'ArrowShape's. Note that whilst an explicit list is used in the
-- definition of 'ArrowType', there must be at least one tuple and a
-- maximum of 4 (since that is what is required by Dot). For more
-- information, see: <http://graphviz.org/doc/info/arrows.html>
--
-- The 19 basic arrows shown on the overall attributes page have
-- been defined below as a convenience. Parsing of the 5
-- backward-compatible special cases is also supported.
newtype ArrowType = AType [(ArrowModifier, ArrowShape)]
deriving (Eq, Ord, Show, Read)
-- Used for default
normal :: ArrowType
normal = AType [(noMods, Normal)]
-- Used for backward-compatible parsing
eDiamond, openArr, halfOpen, emptyArr, invEmpty :: ArrowType
eDiamond = AType [(openMod, Diamond)]
openArr = AType [(noMods, Vee)]
halfOpen = AType [(ArrMod FilledArrow LeftSide, Vee)]
emptyArr = AType [(openMod, Normal)]
invEmpty = AType [ (noMods, Inv)
, (openMod, Normal)]
instance PrintDot ArrowType where
unqtDot (AType mas) = hcat $ mapM appMod mas
where
appMod (m, a) = unqtDot m <> unqtDot a
instance ParseDot ArrowType where
parseUnqt = specialArrowParse
`onFail`
(AType <$> many1 (liftA2 (,) parseUnqt parseUnqt))
specialArrowParse :: Parse ArrowType
specialArrowParse = stringValue [ ("ediamond", eDiamond)
, ("open", openArr)
, ("halfopen", halfOpen)
, ("empty", emptyArr)
, ("invempty", invEmpty)
]
data ArrowShape = Box
| Crow
| Diamond
| DotArrow
| Inv
| NoArrow
| Normal
| Tee
| Vee
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot ArrowShape where
unqtDot Box = text "box"
unqtDot Crow = text "crow"
unqtDot Diamond = text "diamond"
unqtDot DotArrow = text "dot"
unqtDot Inv = text "inv"
unqtDot NoArrow = text "none"
unqtDot Normal = text "normal"
unqtDot Tee = text "tee"
unqtDot Vee = text "vee"
instance ParseDot ArrowShape where
parseUnqt = stringValue [ ("box", Box)
, ("crow", Crow)
, ("diamond", Diamond)
, ("dot", DotArrow)
, ("inv", Inv)
, ("none", NoArrow)
, ("normal", Normal)
, ("tee", Tee)
, ("vee", Vee)
]
-- | What modifications to apply to an 'ArrowShape'.
data ArrowModifier = ArrMod { arrowFill :: ArrowFill
, arrowSide :: ArrowSide
}
deriving (Eq, Ord, Show, Read)
-- | Apply no modifications to an 'ArrowShape'.
noMods :: ArrowModifier
noMods = ArrMod FilledArrow BothSides
-- | 'OpenArrow' and 'BothSides'
openMod :: ArrowModifier
openMod = ArrMod OpenArrow BothSides
instance PrintDot ArrowModifier where
unqtDot (ArrMod f s) = unqtDot f <> unqtDot s
instance ParseDot ArrowModifier where
parseUnqt = liftA2 ArrMod parseUnqt parseUnqt
data ArrowFill = OpenArrow
| FilledArrow
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot ArrowFill where
unqtDot OpenArrow = char 'o'
unqtDot FilledArrow = empty
instance ParseDot ArrowFill where
parseUnqt = bool FilledArrow OpenArrow . isJust <$> optional (character 'o')
-- Not used individually
parse = parseUnqt
-- | Represents which side (when looking towards the node the arrow is
-- pointing to) is drawn.
data ArrowSide = LeftSide
| RightSide
| BothSides
deriving (Eq, Ord, Bounded, Enum, Show, Read)
instance PrintDot ArrowSide where
unqtDot LeftSide = char 'l'
unqtDot RightSide = char 'r'
unqtDot BothSides = empty
instance ParseDot ArrowSide where
parseUnqt = getSideType <$> optional (oneOf $ map character ['l', 'r'])
where
getSideType = maybe BothSides
(bool RightSide LeftSide . (==) 'l')
-- Not used individually
parse = parseUnqt
|
