{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
{- |
   Module      : Data.GraphViz.Attributes.Values
   Description : Values for use with the Attribute data type
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   Defined to have smaller modules and thus faster compilation times.

 -}
module Data.GraphViz.Attributes.Values where

import qualified Data.GraphViz.Attributes.HTML     as Html
import           Data.GraphViz.Attributes.Internal
import           Data.GraphViz.Internal.State      (getLayerListSep,
                                                    getLayerSep,
                                                    setLayerListSep,
                                                    setLayerSep)
import           Data.GraphViz.Internal.Util       (bool, stringToInt)
import           Data.GraphViz.Parsing
import           Data.GraphViz.Printing

import           Data.List       (intercalate)
import           Data.Maybe      (isJust)
import           Data.Monoid     ((<>))
import           Data.Text.Lazy  (Text)
import qualified Data.Text.Lazy  as T
import           Data.Word       (Word16)
import           System.FilePath (searchPathSeparator, splitSearchPath)

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

{- |

   Some 'Attribute's (mainly label-like ones) take a 'String' argument
   that allows for extra escape codes.  This library doesn't do any
   extra checks or special parsing for these escape codes, but usage
   of 'EscString' rather than 'Text' indicates that the Graphviz
   tools will recognise these extra escape codes for these
   'Attribute's.

   The extra escape codes include (note that these are all Strings):

     [@\\N@] Replace with the name of the node (for Node 'Attribute's).

     [@\\G@] Replace with the name of the graph (for Node 'Attribute's)
             or the name of the graph or cluster, whichever is
             applicable (for Graph, Cluster and Edge 'Attribute's).

     [@\\E@] Replace with the name of the edge, formed by the two
             adjoining nodes and the edge type (for Edge 'Attribute's).

     [@\\T@] Replace with the name of the tail node (for Edge
             'Attribute's).

     [@\\H@] Replace with the name of the head node (for Edge
             'Attribute's).

     [@\\L@] Replace with the object's label (for all 'Attribute's).

   Also, if the 'Attribute' in question is 'Label', 'HeadLabel' or
   'TailLabel', then @\\n@, @\\l@ and @\\r@ split the label into lines
   centered, left-justified and right-justified respectively.

 -}
type EscString = Text

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

-- | Should only have 2D points (i.e. created with 'createPoint').
data Rect = Rect Point Point
            deriving (Eq, Ord, Show, Read)

instance PrintDot Rect where
  unqtDot (Rect p1 p2) = printPoint2DUnqt p1 <> comma <> printPoint2DUnqt p2

  toDot = dquotes . unqtDot

  unqtListToDot = hsep . mapM unqtDot

instance ParseDot Rect where
  parseUnqt = uncurry Rect <$> commaSep' parsePoint2D parsePoint2D

  parse = quotedParse parseUnqt

  parseUnqtList = sepBy1 parseUnqt whitespace1

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

-- | If 'Local', then sub-graphs that are clusters are given special
--   treatment.  'Global' and 'NoCluster' currently appear to be
--   identical and turn off the special cluster processing.
data ClusterMode = Local
                 | Global
                 | NoCluster
                 deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot ClusterMode where
  unqtDot Local     = text "local"
  unqtDot Global    = text "global"
  unqtDot NoCluster = text "none"

instance ParseDot ClusterMode where
  parseUnqt = oneOf [ stringRep Local "local"
                    , stringRep Global "global"
                    , stringRep NoCluster "none"
                    ]

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

-- | Specify where to place arrow heads on an edge.
data DirType = Forward -- ^ Draw a directed edge with an arrow to the
                       --   node it's pointing go.
             | Back    -- ^ Draw a reverse directed edge with an arrow
                       --   to the node it's coming from.
             | Both    -- ^ Draw arrows on both ends of the edge.
             | NoDir   -- ^ Draw an undirected edge.
             deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot DirType where
  unqtDot Forward = text "forward"
  unqtDot Back    = text "back"
  unqtDot Both    = text "both"
  unqtDot NoDir   = text "none"

instance ParseDot DirType where
  parseUnqt = oneOf [ stringRep Forward "forward"
                    , stringRep Back "back"
                    , stringRep Both "both"
                    , stringRep NoDir "none"
                    ]

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

-- | Only when @mode == 'IpSep'@.
data DEConstraints = EdgeConstraints
                   | NoConstraints
                   | HierConstraints
                   deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot DEConstraints where
  unqtDot EdgeConstraints = unqtDot True
  unqtDot NoConstraints   = unqtDot False
  unqtDot HierConstraints = text "hier"

instance ParseDot DEConstraints where
  parseUnqt = fmap (bool NoConstraints EdgeConstraints) parse
              `onFail`
              stringRep HierConstraints "hier"

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

-- | Either a 'Double' or a (2D) 'Point' (i.e. created with
--   'createPoint').
--
--   Whilst it is possible to create a 'Point' value with either a
--   third co-ordinate or a forced position, these are ignored for
--   printing/parsing.
--
--   An optional prefix of @\'+\'@ is allowed when parsing.
data DPoint = DVal Double
            | PVal Point
            deriving (Eq, Ord, Show, Read)

instance PrintDot DPoint where
  unqtDot (DVal d) = unqtDot d
  unqtDot (PVal p) = printPoint2DUnqt p

  toDot (DVal d) = toDot d
  toDot (PVal p) = printPoint2D p

instance ParseDot DPoint where
  parseUnqt = optional (character '+')
              *> oneOf [ PVal <$> parsePoint2D
                       , DVal <$> parseUnqt
                       ]

  parse = quotedParse parseUnqt -- A `+' would need to be quoted.
          `onFail`
          fmap DVal (parseSignedFloat False) -- Don't use parseUnqt!

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

-- | The mapping used for 'FontName' values in SVG output.
--
--   More information can be found at <http://www.graphviz.org/doc/fontfaq.txt>.
data SVGFontNames = SvgNames        -- ^ Use the legal generic SVG font names.
                  | PostScriptNames -- ^ Use PostScript font names.
                  | FontConfigNames -- ^ Use fontconfig font conventions.
                  deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot SVGFontNames where
  unqtDot SvgNames        = text "svg"
  unqtDot PostScriptNames = text "ps"
  unqtDot FontConfigNames = text "gd"

instance ParseDot SVGFontNames where
  parseUnqt = oneOf [ stringRep SvgNames "svg"
                    , stringRep PostScriptNames "ps"
                    , stringRep FontConfigNames "gd"
                    ]

  parse = stringRep SvgNames "\"\""
          `onFail`
          optionalQuoted parseUnqt

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

-- | Maximum width and height of drawing in inches.
data GraphSize = GSize { width       :: Double
                         -- | If @Nothing@, then the height is the
                         --   same as the width.
                       , height      :: Maybe Double
                         -- | If drawing is smaller than specified
                         --   size, this value determines whether it
                         --   is scaled up.
                       , desiredSize :: Bool
                       }
               deriving (Eq, Ord, Show, Read)

instance PrintDot GraphSize where
  unqtDot (GSize w mh ds) = bool id (<> char '!') ds
                            . maybe id (\h -> (<> unqtDot h) . (<> comma)) mh
                            $ unqtDot w

  toDot (GSize w Nothing False) = toDot w
  toDot gs                      = dquotes $ unqtDot gs

instance ParseDot GraphSize where
  parseUnqt = GSize <$> parseUnqt
                    <*> optional (parseComma *> whitespace *> parseUnqt)
                    <*> (isJust <$> optional (character '!'))

  parse = quotedParse parseUnqt
          `onFail`
          fmap (\ w -> GSize w Nothing False) (parseSignedFloat False)

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

-- | For 'Neato' unless indicated otherwise.
data ModeType = Major
              | KK
              | Hier
              | IpSep
              | SpringMode -- ^ For 'Sfdp', requires Graphviz >= 2.32.0.
              | MaxEnt     -- ^ For 'Sfdp', requires Graphviz >= 2.32.0.
              deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot ModeType where
  unqtDot Major      = text "major"
  unqtDot KK         = text "KK"
  unqtDot Hier       = text "hier"
  unqtDot IpSep      = text "ipsep"
  unqtDot SpringMode = text "spring"
  unqtDot MaxEnt     = text "maxent"

instance ParseDot ModeType where
  parseUnqt = oneOf [ stringRep Major "major"
                    , stringRep KK "KK"
                    , stringRep Hier "hier"
                    , stringRep IpSep "ipsep"
                    , stringRep SpringMode "spring"
                    , stringRep MaxEnt "maxent"
                    ]

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

data Model = ShortPath
           | SubSet
           | Circuit
           | MDS
           deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot Model where
  unqtDot ShortPath = text "shortpath"
  unqtDot SubSet    = text "subset"
  unqtDot Circuit   = text "circuit"
  unqtDot MDS       = text "mds"

instance ParseDot Model where
  parseUnqt = oneOf [ stringRep ShortPath "shortpath"
                    , stringRep SubSet "subset"
                    , stringRep Circuit "circuit"
                    , stringRep MDS "mds"
                    ]

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

data Label = StrLabel EscString
           | HtmlLabel Html.Label -- ^ If 'PlainText' is used, the
                                  --   'Html.Label' value is the entire
                                  --   \"shape\"; if anything else
                                  --   except 'PointShape' is used then
                                  --   the 'Html.Label' is embedded
                                  --   within the shape.
           | RecordLabel RecordFields -- ^ For nodes only; requires
                                      --   either 'Record' or
                                      --   'MRecord' as the shape.
           deriving (Eq, Ord, Show, Read)

instance PrintDot Label where
  unqtDot (StrLabel s)     = unqtDot s
  unqtDot (HtmlLabel h)    = angled $ unqtDot h
  unqtDot (RecordLabel fs) = unqtDot fs

  toDot (StrLabel s)     = toDot s
  toDot h@HtmlLabel{}    = unqtDot h
  toDot (RecordLabel fs) = toDot fs

instance ParseDot Label where
  -- Don't have to worry about being able to tell the difference
  -- between an HtmlLabel and a RecordLabel starting with a PortPos,
  -- since the latter will be in quotes and the former won't.

  parseUnqt = oneOf [ HtmlLabel <$> parseAngled parseUnqt
                    , RecordLabel <$> parseUnqt
                    , StrLabel <$> parseUnqt
                    ]

  parse = oneOf [ HtmlLabel <$> parseAngled parse
                , RecordLabel <$> parse
                , StrLabel <$> parse
                ]

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

-- | A RecordFields value should never be empty.
type RecordFields = [RecordField]

-- | Specifies the sub-values of a record-based label.  By default,
--   the cells are laid out horizontally; use 'FlipFields' to change
--   the orientation of the fields (can be applied recursively).  To
--   change the default orientation, use 'RankDir'.
data RecordField = LabelledTarget PortName EscString
                 | PortName PortName -- ^ Will result in no label for
                                     --   that cell.
                 | FieldLabel EscString
                 | FlipFields RecordFields
                 deriving (Eq, Ord, Show, Read)

instance PrintDot RecordField where
  -- Have to use 'printPortName' to add the @\'<\'@ and @\'>\'@.
  unqtDot (LabelledTarget t s) = printPortName t <+> unqtRecordString s
  unqtDot (PortName t)         = printPortName t
  unqtDot (FieldLabel s)       = unqtRecordString s
  unqtDot (FlipFields rs)      = braces $ unqtDot rs

  toDot (FieldLabel s) = printEscaped recordEscChars s
  toDot rf             = dquotes $ unqtDot rf

  unqtListToDot [f] = unqtDot f
  unqtListToDot fs  = hcat . punctuate (char '|') $ mapM unqtDot fs

  listToDot [f] = toDot f
  listToDot fs  = dquotes $ unqtListToDot fs

instance ParseDot RecordField where
  parseUnqt = (liftA2 maybe PortName LabelledTarget
                <$> (PN <$> parseAngled parseRecord)
                <*> optional (whitespace1 *> parseRecord)
              )
              `onFail`
              fmap FieldLabel parseRecord
              `onFail`
              fmap FlipFields (parseBraced parseUnqt)
              `onFail`
              fail "Unable to parse RecordField"

  parse = quotedParse parseUnqt

  parseUnqtList = wrapWhitespace $ sepBy1 parseUnqt (wrapWhitespace $ character '|')

  -- Note: a singleton unquoted 'FieldLabel' is /not/ valid, as it
  -- will cause parsing problems for other 'Label' types.
  parseList = do rfs <- quotedParse parseUnqtList
                 if validRFs rfs
                   then return rfs
                   else fail "This is a StrLabel, not a RecordLabel"
    where
      validRFs [FieldLabel str] = T.any (`elem` recordEscChars) str
      validRFs _                = True

-- | Print a 'PortName' value as expected within a Record data
--   structure.
printPortName :: PortName -> DotCode
printPortName = angled . unqtRecordString . portName

parseRecord :: Parse Text
parseRecord = parseEscaped False recordEscChars []

unqtRecordString :: Text -> DotCode
unqtRecordString = unqtEscaped recordEscChars

recordEscChars :: [Char]
recordEscChars = ['{', '}', '|', ' ', '<', '>']

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

-- | How to treat a node whose name is of the form \"@|edgelabel|*@\"
--   as a special node representing an edge label.
data LabelScheme = NotEdgeLabel        -- ^ No effect
                 | CloseToCenter       -- ^ Make node close to center of neighbor
                 | CloseToOldCenter    -- ^ Make node close to old center of neighbor
                 | RemoveAndStraighten -- ^ Use a two-step process.
                 deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot LabelScheme where
  unqtDot NotEdgeLabel        = int 0
  unqtDot CloseToCenter       = int 1
  unqtDot CloseToOldCenter    = int 2
  unqtDot RemoveAndStraighten = int 3

instance ParseDot LabelScheme where
  -- Use string-based parsing rather than parsing an integer just to make it easier
  parseUnqt = stringValue [ ("0", NotEdgeLabel)
                          , ("1", CloseToCenter)
                          , ("2", CloseToOldCenter)
                          , ("3", RemoveAndStraighten)
                          ]

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

data Point = Point { xCoord   :: Double
                   , yCoord   :: Double
                      -- | Can only be 'Just' for @'Dim' 3@ or greater.
                   , zCoord   :: Maybe Double
                     -- | Input to Graphviz only: specify that the
                     --   node position should not change.
                   , forcePos :: Bool
                   }
           deriving (Eq, Ord, Show, Read)

-- | Create a point with only @x@ and @y@ values.
createPoint     :: Double -> Double -> Point
createPoint x y = Point x y Nothing False

printPoint2DUnqt   :: Point -> DotCode
printPoint2DUnqt p = commaDel (xCoord p) (yCoord p)

printPoint2D :: Point -> DotCode
printPoint2D = dquotes . printPoint2DUnqt

parsePoint2D :: Parse Point
parsePoint2D = uncurry createPoint <$> commaSepUnqt

instance PrintDot Point where
  unqtDot (Point x y mz frs) = bool id (<> char '!') frs
                               . maybe id (\ z -> (<> unqtDot z) . (<> comma)) mz
                               $ commaDel x y

  toDot = dquotes . unqtDot

  unqtListToDot = hsep . mapM unqtDot

  listToDot = dquotes . unqtListToDot

instance ParseDot Point where
  parseUnqt = uncurry Point
                <$> commaSepUnqt
                <*> optional (parseComma *> parseUnqt)
                <*> (isJust <$> optional (character '!'))

  parse = quotedParse parseUnqt

  parseUnqtList = sepBy1 parseUnqt whitespace1

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

-- | How to deal with node overlaps.
--
--   Defaults to 'KeepOverlaps' /except/ for 'Fdp' and 'Sfdp'.
--
--   The ability to specify the number of tries for 'Fdp''s initial
--   force-directed technique is /not/ supported (by default, 'Fdp' uses
--   @9@ passes of its in-built technique, and then @'PrismOverlap'
--   Nothing@).
--
--   For 'Sfdp', the default is @'PrismOverlap' (Just 0)@.
data Overlap = KeepOverlaps
             | ScaleOverlaps -- ^ Remove overlaps by uniformly scaling in x and y.
             | ScaleXYOverlaps -- ^ Remove overlaps by separately scaling x and y.
             | PrismOverlap (Maybe Word16) -- ^ Requires the Prism
                                           --   library to be
                                           --   available (if not,
                                           --   this is equivalent to
                                           --   'VoronoiOverlap'). @'Nothing'@
                                           --   is equivalent to
                                           --   @'Just' 1000@.
                                           --   Influenced by
                                           --   'OverlapScaling'.
             | VoronoiOverlap -- ^ Requires Graphviz >= 2.30.0.
             | CompressOverlap -- ^ Scale layout down as much as
                               --   possible without introducing
                               --   overlaps, assuming none to begin
                               --   with.
             | VpscOverlap -- ^ Uses quadratic optimization to
                           --   minimize node displacement.
             | IpsepOverlap -- ^ Only when @mode == 'IpSep'@
             deriving (Eq, Ord, Show, Read)

instance PrintDot Overlap where
  unqtDot KeepOverlaps     = unqtDot True
  unqtDot ScaleOverlaps    = text "scale"
  unqtDot ScaleXYOverlaps  = text "scalexy"
  unqtDot (PrismOverlap i) = maybe id (flip (<>) . unqtDot) i $ text "prism"
  unqtDot VoronoiOverlap   = text "voronoi"
  unqtDot CompressOverlap  = text "compress"
  unqtDot VpscOverlap      = text "vpsc"
  unqtDot IpsepOverlap     = text "ipsep"

-- | Note that @overlap=false@ defaults to @'PrismOverlap' Nothing@,
--   but if the Prism library isn't available then it is equivalent to
--   'VoronoiOverlap'.
instance ParseDot Overlap where
  parseUnqt = oneOf [ stringRep KeepOverlaps "true"
                    , stringRep ScaleXYOverlaps "scalexy"
                    , stringRep ScaleOverlaps "scale"
                    , string "prism" *> fmap PrismOverlap (optional parse)
                    , stringRep (PrismOverlap Nothing) "false"
                    , stringRep VoronoiOverlap "voronoi"
                    , stringRep CompressOverlap "compress"
                    , stringRep VpscOverlap "vpsc"
                    , stringRep IpsepOverlap "ipsep"
                    ]

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

newtype LayerSep = LSep Text
                 deriving (Eq, Ord, Show, Read)

instance PrintDot LayerSep where
  unqtDot (LSep ls) = setLayerSep (T.unpack ls) *> unqtDot ls

  toDot (LSep ls) = setLayerSep (T.unpack ls) *> toDot ls

instance ParseDot LayerSep where
  parseUnqt = do ls <- parseUnqt
                 setLayerSep $ T.unpack ls
                 return $ LSep ls

  parse = do ls <- parse
             setLayerSep $ T.unpack ls
             return $ LSep ls

newtype LayerListSep = LLSep Text
                     deriving (Eq, Ord, Show, Read)

instance PrintDot LayerListSep where
  unqtDot (LLSep ls) = setLayerListSep (T.unpack ls) *> unqtDot ls

  toDot (LLSep ls) = setLayerListSep (T.unpack ls) *> toDot ls

instance ParseDot LayerListSep where
  parseUnqt = do ls <- parseUnqt
                 setLayerListSep $ T.unpack ls
                 return $ LLSep ls

  parse = do ls <- parse
             setLayerListSep $ T.unpack ls
             return $ LLSep ls

type LayerRange = [LayerRangeElem]

data LayerRangeElem = LRID LayerID
                    | LRS LayerID LayerID
                    deriving (Eq, Ord, Show, Read)

instance PrintDot LayerRangeElem where
  unqtDot (LRID lid)    = unqtDot lid
  unqtDot (LRS id1 id2) = do ls <- getLayerSep
                             let s = unqtDot $ head ls
                             unqtDot id1 <> s <> unqtDot id2

  toDot (LRID lid) = toDot lid
  toDot lrs        = dquotes $ unqtDot lrs

  unqtListToDot lr = do lls <- getLayerListSep
                        let s = unqtDot $ head lls
                        hcat . punctuate s $ mapM unqtDot lr

  listToDot [lre] = toDot lre
  listToDot lrs   = dquotes $ unqtListToDot lrs

instance ParseDot LayerRangeElem where
  parseUnqt = ignoreSep LRS parseUnqt parseLayerSep parseUnqt
              `onFail`
              fmap LRID parseUnqt

  parse = quotedParse (ignoreSep LRS parseUnqt parseLayerSep parseUnqt)
          `onFail`
          fmap LRID parse

  parseUnqtList = sepBy parseUnqt parseLayerListSep

  parseList = quotedParse parseUnqtList
              `onFail`
              fmap ((:[]) . LRID) parse

parseLayerSep :: Parse ()
parseLayerSep = do ls <- getLayerSep
                   many1Satisfy (`elem` ls) *> return ()

parseLayerName :: Parse Text
parseLayerName = parseEscaped False [] =<< liftA2 (++) getLayerSep getLayerListSep

parseLayerName' :: Parse Text
parseLayerName' = stringBlock
                  `onFail`
                  quotedParse parseLayerName

parseLayerListSep :: Parse ()
parseLayerListSep = do lls <- getLayerListSep
                       many1Satisfy (`elem` lls) *> return ()

-- | You should not have any layer separator characters for the
--   'LRName' option, as they won't be parseable.
data LayerID = AllLayers
             | LRInt Int
             | LRName Text -- ^ Should not be a number or @"all"@.
             deriving (Eq, Ord, Show, Read)

instance PrintDot LayerID where
  unqtDot AllLayers   = text "all"
  unqtDot (LRInt n)   = unqtDot n
  unqtDot (LRName nm) = unqtDot nm

  toDot (LRName nm) = toDot nm
  -- Other two don't need quotes
  toDot li          = unqtDot li

  unqtListToDot ll = do ls <- getLayerSep
                        let s = unqtDot $ head ls
                        hcat . punctuate s $ mapM unqtDot ll

  listToDot [l] = toDot l
  -- Might not need quotes, but probably will.  Can't tell either
  -- way since we don't know what the separator character will be.
  listToDot ll  = dquotes $ unqtDot ll

instance ParseDot LayerID where
  parseUnqt = checkLayerName <$> parseLayerName -- tests for Int and All

  parse = oneOf [ checkLayerName <$> parseLayerName'
                , LRInt <$> parse -- Mainly for unquoted case.
                ]

checkLayerName     :: Text -> LayerID
checkLayerName str = maybe checkAll LRInt $ stringToInt str
  where
    checkAll = if T.toLower str == "all"
               then AllLayers
               else LRName str

-- Remember: this /must/ be a newtype as we can't use arbitrary
-- LayerID values!

-- | A list of layer names.  The names should all be unique 'LRName'
--   values, and when printed will use an arbitrary character from
--   'defLayerSep'.  The values in the list are implicitly numbered
--   @1, 2, ...@.
newtype LayerList = LL [LayerID]
                  deriving (Eq, Ord, Show, Read)

instance PrintDot LayerList where
  unqtDot (LL ll) = unqtDot ll

  toDot (LL ll) = toDot ll

instance ParseDot LayerList where
  parseUnqt = LL <$> sepBy1 parseUnqt parseLayerSep

  parse = quotedParse parseUnqt
          `onFail`
          fmap (LL . (:[]) . LRName) stringBlock
          `onFail`
          quotedParse (stringRep (LL []) "")

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

data Order = OutEdges -- ^ Draw outgoing edges in order specified.
           | InEdges  -- ^ Draw incoming edges in order specified.
           deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot Order where
  unqtDot OutEdges = text "out"
  unqtDot InEdges  = text "in"

instance ParseDot Order where
  parseUnqt = oneOf [ stringRep OutEdges "out"
                    , stringRep InEdges  "in"
                    ]

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

data OutputMode = BreadthFirst | NodesFirst | EdgesFirst
                deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot OutputMode where
  unqtDot BreadthFirst = text "breadthfirst"
  unqtDot NodesFirst   = text "nodesfirst"
  unqtDot EdgesFirst   = text "edgesfirst"

instance ParseDot OutputMode where
  parseUnqt = oneOf [ stringRep BreadthFirst "breadthfirst"
                    , stringRep NodesFirst "nodesfirst"
                    , stringRep EdgesFirst "edgesfirst"
                    ]

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

data Pack = DoPack
          | DontPack
          | PackMargin Int -- ^ If non-negative, then packs; otherwise doesn't.
          deriving (Eq, Ord, Show, Read)

instance PrintDot Pack where
  unqtDot DoPack         = unqtDot True
  unqtDot DontPack       = unqtDot False
  unqtDot (PackMargin m) = unqtDot m

instance ParseDot Pack where
  -- What happens if it parses 0?  It's non-negative, but parses as False
  parseUnqt = oneOf [ PackMargin <$> parseUnqt
                    , bool DontPack DoPack <$> onlyBool
                    ]

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

data PackMode = PackNode
              | PackClust
              | PackGraph
              | PackArray Bool Bool (Maybe Int) -- ^ Sort by cols, sort
                                                -- by user, number of
                                                -- rows/cols
              deriving (Eq, Ord, Show, Read)

instance PrintDot PackMode where
  unqtDot PackNode           = text "node"
  unqtDot PackClust          = text "clust"
  unqtDot PackGraph          = text "graph"
  unqtDot (PackArray c u mi) = addNum . isU . isC . isUnder
                               $ text "array"
    where
      addNum = maybe id (flip (<>) . unqtDot) mi
      isUnder = if c || u
                then (<> char '_')
                else id
      isC = if c
            then (<> char 'c')
            else id
      isU = if u
            then (<> char 'u')
            else id

instance ParseDot PackMode where
  parseUnqt = oneOf [ stringRep PackNode "node"
                    , stringRep PackClust "clust"
                    , stringRep PackGraph "graph"
                    , do string "array"
                         mcu <- optional $ character '_' *> many1 (satisfy isCU)
                         let c = hasCharacter mcu 'c'
                             u = hasCharacter mcu 'u'
                         mi <- optional parseUnqt
                         return $ PackArray c u mi
                    ]
    where
      hasCharacter ms c = maybe False (elem c) ms
      -- Also checks and removes quote characters
      isCU = (`elem` ['c', 'u'])

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

data Pos = PointPos Point
         | SplinePos [Spline]
         deriving (Eq, Ord, Show, Read)

instance PrintDot Pos where
  unqtDot (PointPos p)   = unqtDot p
  unqtDot (SplinePos ss) = unqtDot ss

  toDot (PointPos p)   = toDot p
  toDot (SplinePos ss) = toDot ss

instance ParseDot Pos where
  -- Have to be careful with this: if we try to parse points first,
  -- then a spline with no start and end points will erroneously get
  -- parsed as a point and then the parser will crash as it expects a
  -- closing quote character...
  parseUnqt = do splns <- parseUnqt
                 case splns of
                   [Spline Nothing Nothing [p]] -> return $ PointPos p
                   _                            -> return $ SplinePos splns

  parse = quotedParse parseUnqt

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

-- | Controls how (and if) edges are represented.
--
--   For 'Dot', the default is 'SplineEdges'; for all other layouts
--   the default is 'LineEdges'.
data EdgeType = SplineEdges -- ^ Except for 'Dot', requires
                            --   non-overlapping nodes (see
                            --   'Overlap').
              | LineEdges
              | NoEdges
              | PolyLine
              | Ortho -- ^ Does not handle ports or edge labels in 'Dot'.
              | Curved -- ^ Requires Graphviz >= 2.30.0.
              | CompoundEdge -- ^ 'Fdp' only
              deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot EdgeType where
  unqtDot SplineEdges  = text "spline"
  unqtDot LineEdges    = text "line"
  unqtDot NoEdges      = empty
  unqtDot PolyLine     = text "polyline"
  unqtDot Ortho        = text "ortho"
  unqtDot Curved       = text "curved"
  unqtDot CompoundEdge = text "compound"

  toDot NoEdges = dquotes empty
  toDot et      = unqtDot et

instance ParseDot EdgeType where
  -- Can't parse NoEdges without quotes.
  parseUnqt = oneOf [ bool LineEdges SplineEdges <$> parse
                    , stringRep SplineEdges "spline"
                    , stringRep LineEdges "line"
                    , stringRep NoEdges "none"
                    , stringRep PolyLine "polyline"
                    , stringRep Ortho "ortho"
                    , stringRep Curved "curved"
                    , stringRep CompoundEdge "compound"
                    ]

  parse = stringRep NoEdges "\"\""
          `onFail`
          optionalQuoted parseUnqt

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

-- | Upper-case first character is major order;
--   lower-case second character is minor order.
data PageDir = Bl | Br | Tl | Tr | Rb | Rt | Lb | Lt
             deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot PageDir where
  unqtDot Bl = text "BL"
  unqtDot Br = text "BR"
  unqtDot Tl = text "TL"
  unqtDot Tr = text "TR"
  unqtDot Rb = text "RB"
  unqtDot Rt = text "RT"
  unqtDot Lb = text "LB"
  unqtDot Lt = text "LT"

instance ParseDot PageDir where
  parseUnqt = stringValue [ ("BL", Bl)
                          , ("BR", Br)
                          , ("TL", Tl)
                          , ("TR", Tr)
                          , ("RB", Rb)
                          , ("RT", Rt)
                          , ("LB", Lb)
                          , ("LT", Lt)
                          ]

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

-- | The number of points in the list must be equivalent to 1 mod 3;
--   note that this is not checked.
data Spline = Spline { endPoint     :: Maybe Point
                     , startPoint   :: Maybe Point
                     , splinePoints :: [Point]
                     }
            deriving (Eq, Ord, Show, Read)

instance PrintDot Spline where
  unqtDot (Spline me ms ps) = addE . addS
                             . hsep
                             $ mapM unqtDot ps
    where
      addP t = maybe id ((<+>) . commaDel t)
      addS = addP 's' ms
      addE = addP 'e' me

  toDot = dquotes . unqtDot

  unqtListToDot = hcat . punctuate semi . mapM unqtDot

  listToDot = dquotes . unqtListToDot

instance ParseDot Spline where
  parseUnqt = Spline <$> parseP 'e' <*> parseP 's'
                     <*> sepBy1 parseUnqt whitespace1
      where
        parseP t = optional (character t *> parseComma *> parseUnqt <* whitespace1)

  parse = quotedParse parseUnqt

  parseUnqtList = sepBy1 parseUnqt (character ';')

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

data QuadType = NormalQT
              | FastQT
              | NoQT
              deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot QuadType where
  unqtDot NormalQT = text "normal"
  unqtDot FastQT   = text "fast"
  unqtDot NoQT     = text "none"

instance ParseDot QuadType where
  -- Have to take into account the slightly different interpretation
  -- of Bool used as an option for parsing QuadType
  parseUnqt = oneOf [ stringRep NormalQT "normal"
                    , stringRep FastQT "fast"
                    , stringRep NoQT "none"
                    , character '2' *> return FastQT -- weird bool
                    , bool NoQT NormalQT <$> parse
                    ]

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

-- | Specify the root node either as a Node attribute or a Graph attribute.
data Root = IsCentral     -- ^ For Nodes only
          | NotCentral    -- ^ For Nodes only
          | NodeName Text -- ^ For Graphs only
          deriving (Eq, Ord, Show, Read)

instance PrintDot Root where
  unqtDot IsCentral    = unqtDot True
  unqtDot NotCentral   = unqtDot False
  unqtDot (NodeName n) = unqtDot n

  toDot (NodeName n) = toDot n
  toDot r            = unqtDot r

instance ParseDot Root where
  parseUnqt = fmap (bool NotCentral IsCentral) onlyBool
              `onFail`
              fmap NodeName parseUnqt

  parse = optionalQuoted (bool NotCentral IsCentral <$> onlyBool)
          `onFail`
          fmap NodeName parse

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

data RankType = SameRank
              | MinRank
              | SourceRank
              | MaxRank
              | SinkRank
              deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot RankType where
  unqtDot SameRank   = text "same"
  unqtDot MinRank    = text "min"
  unqtDot SourceRank = text "source"
  unqtDot MaxRank    = text "max"
  unqtDot SinkRank   = text "sink"

instance ParseDot RankType where
  parseUnqt = stringValue [ ("same", SameRank)
                          , ("min", MinRank)
                          , ("source", SourceRank)
                          , ("max", MaxRank)
                          , ("sink", SinkRank)
                          ]

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

data RankDir = FromTop
             | FromLeft
             | FromBottom
             | FromRight
             deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot RankDir where
  unqtDot FromTop    = text "TB"
  unqtDot FromLeft   = text "LR"
  unqtDot FromBottom = text "BT"
  unqtDot FromRight  = text "RL"

instance ParseDot RankDir where
  parseUnqt = oneOf [ stringRep FromTop "TB"
                    , stringRep FromLeft "LR"
                    , stringRep FromBottom "BT"
                    , stringRep FromRight "RL"
                    ]

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

-- | Geometries of shapes are affected by the attributes 'Regular',
--   'Peripheries' and 'Orientation'.
data Shape
    = BoxShape -- ^ Has synonyms of /rect/ and /rectangle/.
    | Polygon  -- ^ Also affected by 'Sides', 'Skew' and 'Distortion'.
    | Ellipse  -- ^ Has synonym of /oval/.
    | Circle
    | PointShape -- ^ Only affected by 'Peripheries', 'Width' and
                 --   'Height'.
    | Egg
    | Triangle
    | PlainText -- ^ Has synonym of /none/.  Recommended for
                --   'HtmlLabel's.
    | DiamondShape
    | Trapezium
    | Parallelogram
    | House
    | Pentagon
    | Hexagon
    | Septagon
    | Octagon
    | DoubleCircle
    | DoubleOctagon
    | TripleOctagon
    | InvTriangle
    | InvTrapezium
    | InvHouse
    | MDiamond
    | MSquare
    | MCircle
    | Square
    | Star      -- ^ Requires Graphviz >= 2.32.0.
    | Underline -- ^ Requires Graphviz >= 2.36.0.
    | Note
    | Tab
    | Folder
    | Box3D
    | Component
    | Promoter         -- ^ Requires Graphviz >= 2.30.0.
    | CDS              -- ^ Requires Graphviz >= 2.30.0.
    | Terminator       -- ^ Requires Graphviz >= 2.30.0.
    | UTR              -- ^ Requires Graphviz >= 2.30.0.
    | PrimerSite       -- ^ Requires Graphviz >= 2.30.0.
    | RestrictionSite  -- ^ Requires Graphviz >= 2.30.0.
    | FivePovOverhang  -- ^ Requires Graphviz >= 2.30.0.
    | ThreePovOverhang -- ^ Requires Graphviz >= 2.30.0.
    | NoOverhang       -- ^ Requires Graphviz >= 2.30.0.
    | Assembly         -- ^ Requires Graphviz >= 2.30.0.
    | Signature        -- ^ Requires Graphviz >= 2.30.0.
    | Insulator        -- ^ Requires Graphviz >= 2.30.0.
    | Ribosite         -- ^ Requires Graphviz >= 2.30.0.
    | RNAStab          -- ^ Requires Graphviz >= 2.30.0.
    | ProteaseSite     -- ^ Requires Graphviz >= 2.30.0.
    | ProteinStab      -- ^ Requires Graphviz >= 2.30.0.
    | RPromoter        -- ^ Requires Graphviz >= 2.30.0.
    | RArrow           -- ^ Requires Graphviz >= 2.30.0.
    | LArrow           -- ^ Requires Graphviz >= 2.30.0.
    | LPromoter        -- ^ Requires Graphviz >= 2.30.0.
    | Record  -- ^ Must specify the record shape with a 'Label'.
    | MRecord -- ^ Must specify the record shape with a 'Label'.
    deriving (Eq, Ord, Bounded, Enum, Show, Read)

instance PrintDot Shape where
  unqtDot BoxShape         = text "box"
  unqtDot Polygon          = text "polygon"
  unqtDot Ellipse          = text "ellipse"
  unqtDot Circle           = text "circle"
  unqtDot PointShape       = text "point"
  unqtDot Egg              = te