{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}

{- |
   Module      : Data.GraphViz.Attributes
   Description : User-friendly wrappers around Graphviz attributes.
   Copyright   : (c) Matthew Sackman, Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   There are almost 150 possible attributes available for Dot graphs, and
   it can be difficult to know which ones to use.  This module provides
   helper functions for the most commonly used ones.

   The complete list of all possible attributes can be found in
   "Data.GraphViz.Attributes.Complete"; it is possible to use both of
   these modules if you require specific extra attributes that are not
   provided here.

 -}
module Data.GraphViz.Attributes
       ( -- * The definition of attributes
         Attribute
       , Attributes
         -- * Creating labels
         -- $labels
       , toLabel
       , textLabel
       , xLabel
       , xTextLabel
       , forceLabels
       , textLabelValue
       , Labellable(..)
         -- * Colors
         -- $colors
       , X11Color(..)
       , bgColor
       , bgColors
       , fillColor
       , fillColors
       , fontColor
       , penColor
       , color
         -- * Stylistic attributes
         -- $styles
       , penWidth
       , gradientAngle
       , style
       , styles
       , Style
       , dashed
       , dotted
       , solid
       , bold
       , invis
       , filled
       , diagonals
       , striped
       , wedged
       , rounded
       , tapered
       , radial
         -- * Node shapes
       , shape
       , Shape(..)
         -- * Edge arrows
       , arrowTo
       , arrowFrom
         -- ** Specifying where to draw arrows on an edge.
       , edgeEnds
       , DirType(..)
         -- ** Default arrow types.
       , Arrow
         -- *** The 9 primitive arrows.
       , box
       , crow
       , diamond
       , dotArrow
       , inv
       , noArrow
       , normal
       , tee
       , vee
         -- *** 5 derived arrows.
       , oDot
       , invDot
       , invODot
       , oBox
       , oDiamond
         -- * Layout
       , ordering
       , Order(..)
       , rank
       , RankType(..)
       ) where

import           Data.GraphViz.Attributes.Arrows
import           Data.GraphViz.Attributes.Colors
import           Data.GraphViz.Attributes.Colors.X11
import           Data.GraphViz.Attributes.Complete   (Attribute (..),
                                                      Attributes)
import qualified Data.GraphViz.Attributes.HTML       as Html
import           Data.GraphViz.Attributes.Internal
import           Data.GraphViz.Attributes.Values

import qualified Data.Text      as ST
import           Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T

-- -----------------------------------------------------------------------------

{- $labels

   The following escape codes are available for labels (where applicable):

     [@\\N@] Replace with the name of the node.

     [@\\G@] Replace with the name of the graph (for node attributes)
             or the name of the graph or cluster, whichever is
             applicable (for graph, cluster and edge attributes).

     [@\\E@] Replace with the name of the edge, formed by the two
             adjoining nodes and the edge type.

     [@\\T@] Replace with the name of the node the edge is coming from.

     [@\\H@] Replace with the name of the node the edge is going to.

     [@\\n@] Centered newline.

     [@\\l@] Left-justified newline.

     [@\\r@] Right-justified newline.

 -}

-- | A convenience class to make it easier to create labels.  It is
--   highly recommended that you make any other types that you wish to
--   create labels from an instance of this class, preferably via the
--   @String@ or @Text@ instances.
class Labellable a where
  -- | This function only creates a 'Label' value to enable you to use
  --   it for 'Attributes' such as 'HeadLabel', etc.
  toLabelValue :: a -> Label

-- | Equivalent to @'Label' . 'toLabelValue'@; the most common label
--   'Attribute'.
toLabel :: (Labellable a) => a -> Attribute
toLabel :: forall a. Labellable a => a -> Attribute
toLabel = Label -> Attribute
Label (Label -> Attribute) -> (a -> Label) -> a -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Label
forall a. Labellable a => a -> Label
toLabelValue

-- | An alias for 'toLabel' for use with the @OverloadedStrings@
--   extension.
textLabel :: Text -> Attribute
textLabel :: Text -> Attribute
textLabel = Text -> Attribute
forall a. Labellable a => a -> Attribute
toLabel

-- | Create a label /outside/ of a node\/edge.  Currently only in the
--   Graphviz development branch (2.29.*).
xLabel :: (Labellable a) => a -> Attribute
xLabel :: forall a. Labellable a => a -> Attribute
xLabel = Label -> Attribute
XLabel (Label -> Attribute) -> (a -> Label) -> a -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Label
forall a. Labellable a => a -> Label
toLabelValue

-- | An alias for 'xLabel' for use with the @OverloadedStrings@ extension.
xTextLabel :: Text -> Attribute
xTextLabel :: Text -> Attribute
xTextLabel = Text -> Attribute
forall a. Labellable a => a -> Attribute
xLabel

-- | Force the positioning of 'xLabel's, even when it will cause overlaps.
forceLabels :: Attribute
forceLabels :: Attribute
forceLabels = Bool -> Attribute
ForceLabels Bool
True

-- | An alias for 'toLabelValue' for use with the @OverloadedStrings@
--   extension.
textLabelValue :: Text -> Label
textLabelValue :: Text -> Label
textLabelValue = Text -> Label
forall a. Labellable a => a -> Label
toLabelValue

instance Labellable Text where
  toLabelValue :: Text -> Label
toLabelValue = Text -> Label
StrLabel

instance Labellable ST.Text where
  toLabelValue :: Text -> Label
toLabelValue = Text -> Label
forall a. Labellable a => a -> Label
toLabelValue (Text -> Label) -> (Text -> Text) -> Text -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.fromStrict

instance Labellable Char where
  toLabelValue :: Char -> Label
toLabelValue = Text -> Label
forall a. Labellable a => a -> Label
toLabelValue (Text -> Label) -> (Char -> Text) -> Char -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton

instance Labellable String where
  toLabelValue :: String -> Label
toLabelValue = Text -> Label
forall a. Labellable a => a -> Label
toLabelValue (Text -> Label) -> (String -> Text) -> String -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance Labellable Int where
  toLabelValue :: Int -> Label
toLabelValue = String -> Label
forall a. Labellable a => a -> Label
toLabelValue (String -> Label) -> (Int -> String) -> Int -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

instance Labellable Double where
  toLabelValue :: Double -> Label
toLabelValue = String -> Label
forall a. Labellable a => a -> Label
toLabelValue (String -> Label) -> (Double -> String) -> Double -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show

instance Labellable Bool where
  toLabelValue :: Bool -> Label
toLabelValue = String -> Label
forall a. Labellable a => a -> Label
toLabelValue (String -> Label) -> (Bool -> String) -> Bool -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show

instance Labellable Html.Label where
  toLabelValue :: Label -> Label
toLabelValue = Label -> Label
HtmlLabel

instance Labellable Html.Text where
  toLabelValue :: Text -> Label
toLabelValue = Label -> Label
forall a. Labellable a => a -> Label
toLabelValue (Label -> Label) -> (Text -> Label) -> Text -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Label
Html.Text

instance Labellable Html.Table where
  toLabelValue :: Table -> Label
toLabelValue = Label -> Label
forall a. Labellable a => a -> Label
toLabelValue (Label -> Label) -> (Table -> Label) -> Table -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table -> Label
Html.Table

instance Labellable RecordFields where
  toLabelValue :: RecordFields -> Label
toLabelValue = RecordFields -> Label
RecordLabel

instance Labellable RecordField where
  toLabelValue :: RecordField -> Label
toLabelValue = RecordFields -> Label
forall a. Labellable a => a -> Label
toLabelValue (RecordFields -> Label)
-> (RecordField -> RecordFields) -> RecordField -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RecordField -> RecordFields -> RecordFields
forall a. a -> [a] -> [a]
:[])

-- | A shorter variant than using @PortName@ from 'RecordField'.
instance Labellable PortName where
  toLabelValue :: PortName -> Label
toLabelValue = RecordField -> Label
forall a. Labellable a => a -> Label
toLabelValue (RecordField -> Label)
-> (PortName -> RecordField) -> PortName -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortName -> RecordField
PortName

-- | A shorter variant than using 'LabelledTarget'.
instance Labellable (PortName, EscString) where
  toLabelValue :: (PortName, Text) -> Label
toLabelValue = RecordField -> Label
forall a. Labellable a => a -> Label
toLabelValue (RecordField -> Label)
-> ((PortName, Text) -> RecordField) -> (PortName, Text) -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PortName -> Text -> RecordField)
-> (PortName, Text) -> RecordField
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PortName -> Text -> RecordField
LabelledTarget

-- -----------------------------------------------------------------------------

{- $colors

   The recommended way of dealing with colors in Dot graphs is to use the
   named 'X11Color's rather than explicitly specifying RGB, RGBA or HSV
   colors.

   These functions also allow you to use SVG and Brewer colors, but
   X11 colors are generally preferable.  If you wish to use SVG
   colors, either import this module hiding 'X11Color' or import the
   SVG module qualified.

 -}

-- | Specify the background color of a graph or cluster.  For
--   clusters, if @'style' 'filled'@ is used, then 'fillColor' will
--   override it.
bgColor :: (NamedColor nc) => nc -> Attribute
bgColor :: forall nc. NamedColor nc => nc -> Attribute
bgColor = ColorList -> Attribute
BgColor (ColorList -> Attribute) -> (nc -> ColorList) -> nc -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Color] -> ColorList
toColorList ([Color] -> ColorList) -> (nc -> [Color]) -> nc -> ColorList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> [Color] -> [Color]
forall a. a -> [a] -> [a]
:[]) (Color -> [Color]) -> (nc -> Color) -> nc -> [Color]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor

-- | As with 'bgColor', but add a second color to create a gradient
--   effect.  Requires Graphviz >= 2.29.0.
bgColors       :: (NamedColor nc) => nc -> nc -> Attribute
bgColors :: forall nc. NamedColor nc => nc -> nc -> Attribute
bgColors nc
c1 nc
c2 = ColorList -> Attribute
BgColor (ColorList -> Attribute)
-> ([Color] -> ColorList) -> [Color] -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Color] -> ColorList
toColorList ([Color] -> Attribute) -> [Color] -> Attribute
forall a b. (a -> b) -> a -> b
$ (nc -> Color) -> [nc] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor [nc
c1,nc
c2]

-- | Specify the fill color of a node, cluster or arrowhead.  Requires
--   @'style' 'filled'@ for nodes and clusters.  For nodes and edges,
--   if this isn't set then the 'color' value is used instead; for
--   clusters, 'bgColor' is used.
fillColor :: (NamedColor nc) => nc -> Attribute
fillColor :: forall nc. NamedColor nc => nc -> Attribute
fillColor = ColorList -> Attribute
FillColor (ColorList -> Attribute) -> (nc -> ColorList) -> nc -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Color] -> ColorList
toColorList ([Color] -> ColorList) -> (nc -> [Color]) -> nc -> ColorList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> [Color] -> [Color]
forall a. a -> [a] -> [a]
:[]) (Color -> [Color]) -> (nc -> Color) -> nc -> [Color]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor

-- | As with 'fillColor', but add a second color to create a gradient
--   effect.  Requires Graphviz >= 2.29.0.
fillColors       :: (NamedColor nc) => nc -> nc -> Attribute
fillColors :: forall nc. NamedColor nc => nc -> nc -> Attribute
fillColors nc
c1 nc
c2 = ColorList -> Attribute
FillColor (ColorList -> Attribute)
-> ([Color] -> ColorList) -> [Color] -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Color] -> ColorList
toColorList ([Color] -> Attribute) -> [Color] -> Attribute
forall a b. (a -> b) -> a -> b
$ (nc -> Color) -> [nc] -> [Color]
forall a b. (a -> b) -> [a] -> [b]
map nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor [nc
c1,nc
c2]

-- | Specify the color of text.
fontColor :: (NamedColor nc) => nc -> Attribute
fontColor :: forall nc. NamedColor nc => nc -> Attribute
fontColor = Color -> Attribute
FontColor (Color -> Attribute) -> (nc -> Color) -> nc -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor

-- | Specify the color of the bounding box of a cluster.
penColor :: (NamedColor nc) => nc -> Attribute
penColor :: forall nc. NamedColor nc => nc -> Attribute
penColor = Color -> Attribute
PenColor (Color -> Attribute) -> (nc -> Color) -> nc -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor

-- | The @color@ attribute serves several purposes.  As such care must
--   be taken when using it, and it is preferable to use those
--   alternatives that are available when they exist.
--
--   * The color of edges;
--
--   * The bounding color of nodes;
--
--   * The bounding color of clusters (i.e. equivalent to 'penColor');
--
--   * If the 'filled' 'Style' is set, then it defines the
--     background color of nodes and clusters unless 'fillColor' or
--     'bgColor' respectively is set.
color :: (NamedColor nc) => nc -> Attribute
color :: forall nc. NamedColor nc => nc -> Attribute
color = ColorList -> Attribute
Color (ColorList -> Attribute) -> (nc -> ColorList) -> nc -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Color] -> ColorList
toColorList ([Color] -> ColorList) -> (nc -> [Color]) -> nc -> ColorList
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Color -> [Color] -> [Color]
forall a. a -> [a] -> [a]
:[]) (Color -> [Color]) -> (nc -> Color) -> nc -> [Color]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. nc -> Color
forall nc. NamedColor nc => nc -> Color
toColor

-- -----------------------------------------------------------------------------

{- $styles

   Various stylistic attributes to customise how items are drawn.
   Unless specified otherwise, all 'Style's are available for nodes;
   those specified also can be used for edges and clusters.

 -}

-- | A particular style type to be used.
type Style = StyleItem

style :: Style -> Attribute
style :: Style -> Attribute
style = [Style] -> Attribute
styles ([Style] -> Attribute) -> (Style -> [Style]) -> Style -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style -> [Style] -> [Style]
forall a. a -> [a] -> [a]
:[])

styles :: [Style] -> Attribute
styles :: [Style] -> Attribute
styles = [Style] -> Attribute
Style

-- | Also available for edges.
dashed :: Style
dashed :: Style
dashed = StyleName -> [Text] -> Style
SItem StyleName
Dashed []

-- | Also available for edges.
dotted :: Style
dotted :: Style
dotted = StyleName -> [Text] -> Style
SItem StyleName
Dotted []

-- | Also available for edges.
solid :: Style
solid :: Style
solid = StyleName -> [Text] -> Style
SItem StyleName
Solid []

-- | Also available for edges.
invis :: Style
invis :: Style
invis = StyleName -> [Text] -> Style
SItem StyleName
Invisible []

-- | Also available for edges.
bold :: Style
bold :: Style
bold = StyleName -> [Text] -> Style
SItem StyleName
Bold []

-- | Also available for clusters.
filled :: Style
filled :: Style
filled = StyleName -> [Text] -> Style
SItem StyleName
Filled []

-- | Also available for clusters.
rounded :: Style
rounded :: Style
rounded = StyleName -> [Text] -> Style
SItem StyleName
Rounded []

-- | Only available for nodes.
diagonals :: Style
diagonals :: Style
diagonals = StyleName -> [Text] -> Style
SItem StyleName
Diagonals []

-- | Only available for rectangularly-shaped nodes and
--   clusters.  Requires Graphviz >= 2.30.0.
striped :: Style
striped :: Style
striped = StyleName -> [Text] -> Style
SItem StyleName
Striped []

-- | Only available for elliptically-shaped nodes.  Requires Graphviz
--   >= 2.30.0.
wedged :: Style
wedged :: Style
wedged = StyleName -> [Text] -> Style
SItem StyleName
Wedged []

-- | Only available for edges; creates a tapered edge between the two
--   nodes.  Requires Graphviz >= 2.29.0.
tapered :: Style
tapered :: Style
tapered = StyleName -> [Text] -> Style
SItem StyleName
Tapered []

-- | Available for nodes, clusters and edges.  When using
--   'gradientAngle', indicates that a radial gradient should be used.
--   Requires Graphviz >= 2.29.0.
radial :: Style
radial :: Style
radial = StyleName -> [Text] -> Style
SItem StyleName
Radial []

-- | Specify the width of lines.  Valid for clusters, nodes and edges.
penWidth :: Double -> Attribute
penWidth :: Double -> Attribute
penWidth = Double -> Attribute
PenWidth

-- | Specify the angle at which gradient fills are drawn; for use with
--   'bgColors' and 'fillColors'.  Requires Graphviz >= 2.29.0.
gradientAngle :: Int -> Attribute
gradientAngle :: Int -> Attribute
gradientAngle = Int -> Attribute
GradientAngle

-- -----------------------------------------------------------------------------

-- | The shape of a node.
shape :: Shape -> Attribute
shape :: Shape -> Attribute
shape = Shape -> Attribute
Shape

-- -----------------------------------------------------------------------------

-- | A particular way of drawing the end of an edge.
type Arrow = ArrowType

-- | How to draw the arrow at the node the edge is pointing to.  For
--   an undirected graph, requires either @'edgeEnds' 'Forward'@ or
--   @'edgeEnds' 'Both'@.
arrowTo :: Arrow -> Attribute
arrowTo :: Arrow -> Attribute
arrowTo = Arrow -> Attribute
ArrowHead

-- | How to draw the arrow at the node the edge is coming from.
--   Requires either @'edgeEnds' 'Back'@ or @'edgeEnds' 'Both'@.
arrowFrom :: Arrow -> Attribute
arrowFrom :: Arrow -> Attribute
arrowFrom = Arrow -> Attribute
ArrowTail

-- | Specify where to place arrows on an edge.
edgeEnds :: DirType -> Attribute
edgeEnds :: DirType -> Attribute
edgeEnds = DirType -> Attribute
Dir

box, crow, diamond, dotArrow, inv, noArrow, tee, vee :: Arrow
oDot, invDot, invODot, oBox, oDiamond :: Arrow

inv :: Arrow
inv = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Inv)]
dotArrow :: Arrow
dotArrow = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
DotArrow)]
invDot :: Arrow
invDot = [(ArrowModifier, ArrowShape)] -> Arrow
AType [ (ArrowModifier
noMods, ArrowShape
Inv)
               , (ArrowModifier
noMods, ArrowShape
DotArrow)]
oDot :: Arrow
oDot = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowFill -> ArrowSide -> ArrowModifier
ArrMod ArrowFill
OpenArrow ArrowSide
BothSides, ArrowShape
DotArrow)]
invODot :: Arrow
invODot = [(ArrowModifier, ArrowShape)] -> Arrow
AType [ (ArrowModifier
noMods, ArrowShape
Inv)
                , (ArrowModifier
openMod, ArrowShape
DotArrow)]
noArrow :: Arrow
noArrow = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
NoArrow)]
tee :: Arrow
tee = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Tee)]
diamond :: Arrow
diamond = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Diamond)]
oDiamond :: Arrow
oDiamond = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
openMod, ArrowShape
Diamond)]
crow :: Arrow
crow = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Crow)]
box :: Arrow
box = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Box)]
oBox :: Arrow
oBox = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
openMod, ArrowShape
Box)]
vee :: Arrow
vee = [(ArrowModifier, ArrowShape)] -> Arrow
AType [(ArrowModifier
noMods, ArrowShape
Vee)]

-- -----------------------------------------------------------------------------

-- | Specify an ordering of edges of a node: either the outgoing or
--   the incoming edges of a node must appear left-to-right in the
--   same order in which they are defined in the input.
--
--   When specified as both a global graph or sub-graph level
--   attribute, then it takes precedence over an attribute specified
--   for an individual node.
ordering :: Order -> Attribute
ordering :: Order -> Attribute
ordering = Order -> Attribute
Ordering

-- -----------------------------------------------------------------------------

-- | When using @dot@, this allows you to control relative placement
--   of sub-graphs and clusters.
rank :: RankType -> Attribute
rank :: RankType -> Attribute
rank = RankType -> Attribute
Rank