{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}

{- |
   Module      : Data.GraphViz.Types.Common
   Description : Common internal functions for dealing with overall types.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   This module provides common functions used by both
   "Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised".
-}
module Data.GraphViz.Types.Common where

import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.State
import Data.GraphViz.Util
import Data.GraphViz.Attributes.Complete( Attributes, Attribute(HeadPort, TailPort)
                                        , usedByGraphs, usedByClusters
                                        , usedByNodes)
import Data.GraphViz.Attributes.Internal(PortPos, parseEdgeBasedPP)

import Data.Maybe(isJust)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Read as T
import Data.Text.Lazy(Text)
import Control.Monad(when, unless)

-- -----------------------------------------------------------------------------
-- This is re-exported by Data.GraphViz.Types

-- | A polymorphic type that covers all possible ID values allowed by
--   Dot syntax.  Note that whilst the 'ParseDot' and 'PrintDot'
--   instances for 'String' will properly take care of the special
--   cases for numbers, they are treated differently here.
data GraphID = Str Text
             | Int Int
             | Dbl Double
             deriving (Eq, Ord, Show, Read)

instance PrintDot GraphID where
  unqtDot (Str str) = unqtDot str
  unqtDot (Int i)   = unqtDot i
  unqtDot (Dbl d)   = unqtDot d

  toDot (Str str) = toDot str
  toDot gID       = unqtDot gID

instance ParseDot GraphID where
  parseUnqt = stringNum <$> parseUnqt

  parse = stringNum <$> parse
          `adjustErr`
          ("Not a valid GraphID\n\t"++)

stringNum     :: Text -> GraphID
stringNum str = maybe checkDbl Int $ stringToInt str
  where
    checkDbl = if isNumString str
               then Dbl $ toDouble str
               else Str str

numericValue           :: GraphID -> Maybe Int
numericValue (Str str) = either (const Nothing) (Just . round . fst)
                         $ T.signed T.double str
numericValue (Int n)   = Just n
numericValue (Dbl x)   = Just $ round x

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

-- Re-exported by Data.GraphViz.Types.*

-- | Represents a list of top-level list of 'Attribute's for the
--   entire graph/sub-graph.  Note that 'GraphAttrs' also applies to
--   'DotSubGraph's.
--
--   Note that Dot allows a single 'Attribute' to be listed on a line;
--   if this is the case then when parsing, the type of 'Attribute' it
--   is determined and that type of 'GlobalAttribute' is created.
data GlobalAttributes = GraphAttrs { attrs :: Attributes }
                      | NodeAttrs  { attrs :: Attributes }
                      | EdgeAttrs  { attrs :: Attributes }
                      deriving (Eq, Ord, Show, Read)

instance PrintDot GlobalAttributes where
  unqtDot = printAttrBased True printGlobAttrType globAttrType attrs

  unqtListToDot = printAttrBasedList True printGlobAttrType globAttrType attrs

  listToDot = unqtListToDot

-- GraphAttrs, NodeAttrs and EdgeAttrs respectively
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal = foldr select ([], [], [])
  where
    select globA ~(gs,ns,es) = case globA of
                                 GraphAttrs as -> (as ++ gs, ns, es)
                                 NodeAttrs  as -> (gs, as ++ ns, es)
                                 EdgeAttrs  as -> (gs, ns, as ++ es)

unPartitionGlobal :: (Attributes, Attributes, Attributes) -> [GlobalAttributes]
unPartitionGlobal (gas,nas,eas) = [ GraphAttrs gas
                                  , NodeAttrs  nas
                                  , EdgeAttrs  eas
                                  ]

printGlobAttrType              :: GlobalAttributes -> DotCode
printGlobAttrType GraphAttrs{} = text "graph"
printGlobAttrType NodeAttrs{}  = text "node"
printGlobAttrType EdgeAttrs{}  = text "edge"

instance ParseDot GlobalAttributes where
  -- Not using parseAttrBased here because we want to force usage of
  -- Attributes.
  parseUnqt = do gat <- parseGlobAttrType

                 -- Determine if we need to set the attribute type.
                 let mtp = globAttrType $ gat [] -- Only need the constructor
                 oldTp <- getAttributeType
                 maybe (return ()) setAttributeType mtp

                 as <- whitespace *> parse

                 -- Safe to set back even if not changed.
                 setAttributeType oldTp
                 return $ gat as
              `onFail`
              fmap determineType parse

  parse = parseUnqt -- Don't want the option of quoting
          `adjustErr`
          ("Not a valid listing of global attributes\n\t"++)

  -- Have to do this manually because of the special case
  parseUnqtList = parseStatements parseUnqt

  parseList = parseUnqtList

-- Cheat: rather than determine whether it's a graph, cluster or
-- sub-graph just don't set it.
globAttrType :: GlobalAttributes -> Maybe AttributeType
globAttrType NodeAttrs{} = Just NodeAttribute
globAttrType EdgeAttrs{} = Just EdgeAttribute
globAttrType _           = Nothing

parseGlobAttrType :: Parse (Attributes -> GlobalAttributes)
parseGlobAttrType = oneOf [ stringRep GraphAttrs "graph"
                          , stringRep NodeAttrs "node"
                          , stringRep EdgeAttrs "edge"
                          ]

determineType :: Attribute -> GlobalAttributes
determineType attr
  | usedByGraphs attr   = GraphAttrs attr'
  | usedByClusters attr = GraphAttrs attr' -- Also covers SubGraph case
  | usedByNodes attr    = NodeAttrs attr'
  | otherwise           = EdgeAttrs attr' -- Must be for edges.
  where
    attr' = [attr]

withGlob :: (Attributes -> Attributes) -> GlobalAttributes -> GlobalAttributes
withGlob f (GraphAttrs as) = GraphAttrs $ f as
withGlob f (NodeAttrs  as) = NodeAttrs  $ f as
withGlob f (EdgeAttrs  as) = EdgeAttrs  $ f as

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

-- | A node in 'DotGraph'.
data DotNode n = DotNode { nodeID :: n
                         , nodeAttributes :: Attributes
                         }
               deriving (Eq, Ord, Show, Read)

instance (PrintDot n) => PrintDot (DotNode n) where
  unqtDot = printAttrBased False printNodeID
                           (const $ Just NodeAttribute) nodeAttributes

  unqtListToDot = printAttrBasedList False printNodeID
                                     (const $ Just NodeAttribute) nodeAttributes

  listToDot = unqtListToDot

printNodeID :: (PrintDot n) => DotNode n -> DotCode
printNodeID = toDot . nodeID

instance (ParseDot n) => ParseDot (DotNode n) where
  parseUnqt = parseAttrBased NodeAttribute False parseNodeID

  parse = parseUnqt -- Don't want the option of quoting

  parseUnqtList = parseAttrBasedList NodeAttribute False parseNodeID

  parseList = parseUnqtList

parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n)
parseNodeID = DotNode <$> parseAndCheck
  where
    parseAndCheck = do n <- parse
                       me <- optional parseUnwanted
                       maybe (return n) (const notANode) me
    notANode = fail "This appears to be an edge, not a node"
    parseUnwanted = oneOf [ parseEdgeType *> return ()
                          , character ':' *> return () -- PortPos value
                          ]

instance Functor DotNode where
  fmap f n = n { nodeID = f $ nodeID n }

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

-- This is re-exported in Data.GraphViz.Types; defined here so that
-- Generalised can access and use parseEdgeLine (needed for "a -> b ->
-- c"-style edge statements).

-- | An edge in 'DotGraph'.
data DotEdge n = DotEdge { fromNode       :: n
                         , toNode         :: n
                         , edgeAttributes :: Attributes
                         }
               deriving (Eq, Ord, Show, Read)

instance (PrintDot n) => PrintDot (DotEdge n) where
  unqtDot = printAttrBased False printEdgeID
                           (const $ Just EdgeAttribute) edgeAttributes

  unqtListToDot = printAttrBasedList False printEdgeID
                                     (const $ Just EdgeAttribute) edgeAttributes

  listToDot = unqtListToDot

printEdgeID   :: (PrintDot n) => DotEdge n -> DotCode
printEdgeID e = do isDir <- getDirectedness
                   toDot (fromNode e)
                     <+> bool undirEdge' dirEdge' isDir
                     <+> toDot (toNode e)


instance (ParseDot n) => ParseDot (DotEdge n) where
  parseUnqt = parseAttrBased EdgeAttribute False parseEdgeID

  parse = parseUnqt -- Don't want the option of quoting

  -- Have to take into account edges of the type "n1 -> n2 -> n3", etc.
  parseUnqtList = concat <$> parseStatements parseEdgeLine

  parseList = parseUnqtList

parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID = ignoreSep mkEdge parseEdgeNode parseEdgeType parseEdgeNode
              `adjustErr`
              ("Parsed beginning of DotEdge but could not parse Attributes:\n\t"++)
              -- Parse both edge types just to be more liberal

type EdgeNode n = (n, Maybe PortPos)

-- | Takes into account edge statements containing something like
--   @a -> \{b c\}@.
parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]
parseEdgeNodes = parseBraced ( wrapWhitespace
                               -- Should really use sepBy1, but this will do.
                               $ parseStatements parseEdgeNode
                             )
                 `onFail`
                 fmap (:[]) parseEdgeNode

parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n)
parseEdgeNode = liftA2 (,) parse
                           (optional $ character ':' *> parseEdgeBasedPP)

mkEdge :: EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge (eFrom, mFP) (eTo, mTP) = DotEdge eFrom eTo
                                 . addPortPos TailPort mFP
                                 . addPortPos HeadPort mTP

mkEdges :: [EdgeNode n] -> [EdgeNode n]
           -> Attributes -> [DotEdge n]
mkEdges fs ts as = liftA2 (\f t -> mkEdge f t as) fs ts

addPortPos   :: (PortPos -> Attribute) -> Maybe PortPos
                -> Attributes -> Attributes
addPortPos c = maybe id ((:) . c)

parseEdgeType :: Parse Bool
parseEdgeType = wrapWhitespace $ stringRep True dirEdge
                                 `onFail`
                                 stringRep False undirEdge

parseEdgeLine :: (ParseDot n) => Parse [DotEdge n]
parseEdgeLine = do n1 <- parseEdgeNodes
                   ens <- many1 $ parseEdgeType *> parseEdgeNodes
                   let ens' = n1 : ens
                       efs = zipWith mkEdges ens' (tail ens')
                       ef = return $ \ as -> concatMap ($as) efs
                   parseAttrBased EdgeAttribute False ef

instance Functor DotEdge where
  fmap f e = e { fromNode = f $ fromNode e
               , toNode   = f $ toNode e
               }

dirEdge :: String
dirEdge = "->"

dirEdge' :: DotCode
dirEdge' = text $ T.pack dirEdge

undirEdge :: String
undirEdge = "--"

undirEdge' :: DotCode
undirEdge' = text $ T.pack undirEdge

-- -----------------------------------------------------------------------------
-- Labels

dirGraph :: String
dirGraph = "digraph"

dirGraph' :: DotCode
dirGraph' = text $ T.pack dirGraph

undirGraph :: String
undirGraph = "graph"

undirGraph' :: DotCode
undirGraph' = text $ T.pack undirGraph

strGraph :: String
strGraph = "strict"

strGraph' :: DotCode
strGraph' = text $ T.pack strGraph

sGraph :: String
sGraph = "subgraph"

sGraph' :: DotCode
sGraph' = text $ T.pack sGraph

clust :: String
clust = "cluster"

clust' :: DotCode
clust' = text $ T.pack clust

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

printGraphID                 :: (a -> Bool) -> (a -> Bool)
                                -> (a -> Maybe GraphID)
                                -> a -> DotCode
printGraphID str isDir mID g = do setDirectedness isDir'
                                  bool empty strGraph' (str g)
                                    <+> bool undirGraph' dirGraph' isDir'
                                    <+> maybe empty toDot (mID g)
  where
    isDir' = isDir g

parseGraphID   :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a
parseGraphID f = do whitespace
                    str <- isJust <$> optional (parseAndSpace $ string strGraph)
                    dir <- parseAndSpace ( stringRep True dirGraph
                                           `onFail`
                                           stringRep False undirGraph
                                         )
                    setDirectedness dir
                    gID <- optional $ parseAndSpace parse
                    return $ f str dir gID

printStmtBased              :: (a -> DotCode) -> (a -> AttributeType)
                               -> (a -> stmts) -> (stmts -> DotCode)
                               -> a -> DotCode
printStmtBased f ftp r dr a = do gs <- getsGS id
                                 setAttributeType $ ftp a
                                 dc <- printBracesBased (f a) (dr $ r a)
                                 modifyGS (const gs)
                                 return dc

printStmtBasedList            :: (a -> DotCode) -> (a -> AttributeType)
                                 -> (a -> stmts) -> (stmts -> DotCode)
                                 -> [a] -> DotCode
printStmtBasedList f ftp r dr = vcat . mapM (printStmtBased f ftp r dr)

-- Can't use the 'braces' combinator here because we want the closing
-- brace lined up with the h value, which due to indentation might not
-- be the case with braces.
printBracesBased     :: DotCode -> DotCode -> DotCode
printBracesBased h i = vcat $ sequence [ h <+> lbrace
                                       , ind i
                                       , rbrace
                                       ]
  where
    ind = indent 4

-- | This /must/ only be used for sub-graphs, etc.
parseBracesBased      :: AttributeType -> Parse a -> Parse a
parseBracesBased tp p = do gs <- getsGS id
                           setAttributeType tp
                           a <- whitespace *> parseBraced (wrapWhitespace p)
                           modifyGS (const gs)
                           return a
                        `adjustErr`
                        ("Not a valid value wrapped in braces.\n\t"++)

printSubGraphID     :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode
printSubGraphID f a = sGraph'
                      <+> maybe cl dtID mID
  where
    (isCl, mID) = f a
    cl = bool empty clust' isCl
    dtID = printSGID isCl

-- | Print the actual ID for a 'DotSubGraph'.
printSGID          :: Bool -> GraphID -> DotCode
printSGID isCl sID = bool noClust addClust isCl
  where
    noClust = toDot sID
    -- Have to manually render it as we need the un-quoted form.
    addClust = toDot . T.append (T.pack clust) . T.cons '_'
               . renderDot $ mkDot sID
    mkDot (Str str) = text str -- Quotes will be escaped later
    mkDot gid       = unqtDot gid

parseSubGraph         :: (Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c
parseSubGraph pid pst = do (isC, fID) <- parseSubGraphID pid
                           let tp = bool SubGraphAttribute ClusterAttribute isC
                           fID <$> parseBracesBased tp pst

parseSubGraphID   :: (Bool -> Maybe GraphID -> c) -> Parse (Bool,c)
parseSubGraphID f = appl <$> (string sGraph *> whitespace1 *> parseSGID)
  where
    appl (isC, mid) = (isC, f isC mid)

parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID = oneOf [ getClustFrom <$> parseAndSpace parse
                  , return (False, Nothing)
                  ]
  where
    -- If it's a String value, check to see if it's actually a
    -- cluster_Blah value; thus need to manually re-parse it.
    getClustFrom (Str str) = runParser' pStr str
    getClustFrom gid       = (False, Just gid)

    checkCl = stringRep True clust
    pStr = do isCl <- checkCl
                      `onFail`
                      return False
              when isCl $ optional (character '_') *> return ()
              sID <- optional pID
              let sID' = if sID == emptyID
                         then Nothing
                         else sID
              return (isCl, sID')

    emptyID = Just $ Str ""

    -- For Strings, there are no more quotes to unescape, so consume
    -- what you can.
    pID = stringNum <$> manySatisfy (const True)

{- This is a much nicer definition, but unfortunately it doesn't work.
   The problem is that Graphviz decides that a subgraph is a cluster
   if the ID starts with "cluster" (no quotes); thus, we _have_ to do
   the double layer of parsing to get it to work :@

            do isCl <- stringRep True clust
                       `onFail`
                       return False
               sID <- optional $ do when isCl
                                      $ optional (character '_') *> return ()
                                    parseUnqt
               when (isCl || isJust sID) $ whitespace1 *> return ()
               return (isCl, sID)
-}

-- The Bool is True for global, False for local.
printAttrBased                    :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
                                     -> (a -> Attributes) -> a -> DotCode
printAttrBased prEmp ff ftp fas a = do oldType <- getAttributeType
                                       maybe (return ()) setAttributeType mtp
                                       oldCS <- getColorScheme
                                       (dc <> semi) <* unless prEmp (setColorScheme oldCS)
                                                    <* setAttributeType oldType
  where
    mtp = ftp a
    f = ff a
    dc = case fas a of
           [] | not prEmp -> f
           as -> f <+> toDot as

-- The Bool is True for global, False for local.
printAttrBasedList                    :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
                                         -> (a -> Attributes) -> [a] -> DotCode
printAttrBasedList prEmp ff ftp fas = vcat . mapM (printAttrBased prEmp ff ftp fas)

-- The Bool is True for global, False for local.
parseAttrBased         :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased tp lc p = do oldType <- getAttributeType
                            setAttributeType tp
                            oldCS <- getColorScheme
                            f <- p
                            atts <- tryParseList' (whitespace *> parse)
                            unless lc $ setColorScheme oldCS
                            when (tp /= oldType) $ setAttributeType oldType
                            return $ f atts
                         `adjustErr`
                         ("Not a valid attribute-based structure\n\t"++)

-- The Bool is True for global, False for local.
parseAttrBasedList       :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList tp lc = parseStatements . parseAttrBased tp lc

-- | Parse the separator (and any other whitespace1 present) between statements.
statementEnd :: Parse ()
statementEnd = parseSplit *> newline'
  where
    parseSplit = (whitespace *> oneOf [ character ';' *> return ()
                                      , newline
                                      ]
                 )
                 `onFail`
                 whitespace1

parseStatements   :: Parse a -> Parse [a]
parseStatements p = sepBy (whitespace *> p) statementEnd
                    `discard`
                    optional statementEnd