{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

{- |
   Module      : Data.GraphViz.Types.Generalised.
   Description : Alternate definition of the Graphviz types.
   Copyright   : (c) Ivan Lazar Miljenovic
   License     : 3-Clause BSD-style
   Maintainer  : Ivan.Miljenovic@gmail.com

   The generalised Dot representation most closely matches the
   implementation of actual Dot code, as it places no restrictions on
   ordering of elements, etc.  As such it should be able to parse any
   existing Dot code (taking into account the parsing
   limitations/assumptions).

   The sample graph could be implemented (this is actually a prettied
   version of parsing in the Dot code) as:

   > DotGraph { strictGraph = False
   >          , directedGraph = True
   >          , graphID = Just (Str "G")
   >          , graphStatements = Seq.fromList [ SG $ DotSG { isCluster = True
   >                                                        , subGraphID = Just (Int 0)
   >                                                        , subGraphStmts = Seq.fromList [ GA $ GraphAttrs [style filled]
   >                                                                                       , GA $ GraphAttrs [color LightGray]
   >                                                                                       , GA $ NodeAttrs [style filled, color White]
   >                                                                                       , DE $ DotEdge "a0" "a1" []
   >                                                                                       , DE $ DotEdge "a1" "a2" []
   >                                                                                       , DE $ DotEdge "a2" "a3" []
   >                                                                                       , GA $ GraphAttrs [textLabel "process #1"]]}
   >                                           , SG $ DotSG { isCluster = True
   >                                                        , subGraphID = Just (Int 1)
   >                                                        , subGraphStmts = fromList [ GA $ NodeAttrs [style filled]
   >                                                                                   , DE $ DotEdge "b0" "b1" []
   >                                                                                   , DE $ DotEdge "b1" "b2" []
   >                                                                                   , DE $ DotEdge "b2" "b3" []
   >                                                                                   , GA $ GraphAttrs [textLabel "process #2"]
   >                                                                                   , GA $ GraphAttrs [color Blue]]}
   >                                           , DE $ DotEdge "start" "a0" []
   >                                           , DE $ DotEdge "start" "b0" []
   >                                           , DE $ DotEdge "a1" "b3" []
   >                                           , DE $ DotEdge "b2" "a3" []
   >                                           , DE $ DotEdge "a3" "a0" []
   >                                           , DE $ DotEdge "a3" "end" []
   >                                           , DE $ DotEdge "b3" "end" []
   >                                           , DN $ DotNode "start" [shape MDiamond]
   >                                           , DN $ DotNode "end" [shape MSquare]]}

 -}
module Data.GraphViz.Types.Generalised
       ( DotGraph(..)
         -- * Sub-components of a @DotGraph@.
       , DotStatements
       , DotStatement(..)
       , DotSubGraph(..)
         -- * Re-exported from @Data.GraphViz.Types@.
       , GraphID(..)
       , GlobalAttributes(..)
       , DotNode(..)
       , DotEdge(..)
       ) where

import Data.GraphViz.Types
import qualified Data.GraphViz.Types.Canonical as C
import Data.GraphViz.Types.Common
import Data.GraphViz.Types.State
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.Util(bool)

import qualified Data.Sequence as Seq
import Data.Sequence(Seq, (><))
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import Control.Arrow((&&&))
import Control.Monad(liftM)
import Control.Monad.Trans.State(get, put, modify, execState, evalState)

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

-- | The internal representation of a generalised graph in Dot form.
data DotGraph n = DotGraph { -- | If 'True', no multiple edges are drawn.
                             strictGraph     :: Bool
                           , directedGraph   :: Bool
                           , graphID         :: Maybe GraphID
                           , graphStatements :: DotStatements n
                           }
                deriving (Eq, Ord, Show, Read)

instance (Ord n) => DotRepr DotGraph n where
  fromCanonical = generaliseDotGraph

  getID = graphID

  setID i g = g { graphID = Just i }

  graphIsDirected = directedGraph

  setIsDirected d g = g { directedGraph = d }

  graphIsStrict = strictGraph

  setStrictness s g = g { strictGraph = s }

  mapDotGraph = fmap

  graphStructureInformation = getGraphInfo
                              . statementStructure . graphStatements

  nodeInformation wGlobal = getNodeLookup wGlobal
                            . statementNodes . graphStatements

  edgeInformation wGlobal = getDotEdges wGlobal
                            . statementEdges . graphStatements

  unAnonymise = renumber

instance (Ord n, PrintDot n) => PrintDotRepr DotGraph n
instance (Ord n, ParseDot n) => ParseDotRepr DotGraph n
instance (Ord n, PrintDot n, ParseDot n) => PPDotRepr DotGraph n

instance (PrintDot n) => PrintDot (DotGraph n) where
  unqtDot = printStmtBased printGraphID' graphStatements printGStmts
    where
      printGraphID' = printGraphID strictGraph directedGraph graphID

instance (ParseDot n) => ParseDot (DotGraph n) where
  parseUnqt = parseStmtBased parseGStmts (parseGraphID DotGraph)

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

-- | Assumed to be an injective mapping function.
instance Functor DotGraph where
  fmap f g = g { graphStatements = (fmap . fmap) f $ graphStatements g }

-- | Convert a 'DotGraph' to a 'DotGraph', keeping the same order of
--   statements.
generaliseDotGraph    :: C.DotGraph n -> DotGraph n
generaliseDotGraph dg = DotGraph { strictGraph     = C.strictGraph dg
                                 , directedGraph   = C.directedGraph dg
                                 , graphID         = C.graphID dg
                                 , graphStatements = generaliseStatements
                                                     $ C.graphStatements dg
                                 }

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

type DotStatements n = Seq (DotStatement n)

printGStmts :: (PrintDot n) => DotStatements n -> DotCode
printGStmts = toDot . F.toList

parseGStmts :: (ParseDot n) => Parse (DotStatements n)
parseGStmts = liftM Seq.fromList parse

statementStructure :: DotStatements n -> GraphState ()
statementStructure = F.mapM_ stmtStructure

statementNodes :: (Ord n) => DotStatements n -> NodeState n ()
statementNodes = F.mapM_ stmtNodes

statementEdges :: DotStatements n -> EdgeState n ()
statementEdges = F.mapM_ stmtEdges

generaliseStatements       :: C.DotStatements n -> DotStatements n
generaliseStatements stmts = atts >< sgs >< ns >< es
  where
    atts = Seq.fromList . map GA $ C.attrStmts stmts
    sgs  = Seq.fromList . map (SG . generaliseSubGraph) $ C.subGraphs stmts
    ns   = Seq.fromList . map DN $ C.nodeStmts stmts
    es   = Seq.fromList . map DE $ C.edgeStmts stmts


data DotStatement n = GA GlobalAttributes
                    | SG (DotSubGraph n)
                    | DN (DotNode n)
                    | DE (DotEdge n)
                    deriving (Eq, Ord, Show, Read)

instance (PrintDot n) => PrintDot (DotStatement n) where
  unqtDot (GA ga) = unqtDot ga
  unqtDot (SG sg) = unqtDot sg
  unqtDot (DN dn) = unqtDot dn
  unqtDot (DE de) = unqtDot de

  unqtListToDot = vcat . mapM unqtDot

  listToDot = unqtListToDot

instance (ParseDot n) => ParseDot (DotStatement n) where
  parseUnqt = oneOf [ liftM GA parseUnqt
                    , liftM SG parseUnqt
                    , liftM DN parseUnqt
                    , liftM DE parseUnqt
                    ]

  parse = parseUnqt -- Don't want the option of quoting
          `adjustErr`
          (++ "Not a valid statement")

  parseUnqtList = liftM concat . wrapWhitespace
                  $ parseStatements p
    where
      -- Have to do something special here because of "a -> b -> c"
      -- syntax for edges.
      p = liftM (map DE) parseEdgeLine
          `onFail`
          liftM return parse

  parseList = parseUnqtList

instance Functor DotStatement where
  fmap _ (GA ga) = GA ga -- Have to re-make this to make the type checker happy.
  fmap f (SG sg) = SG $ fmap f sg
  fmap f (DN dn) = DN $ fmap f dn
  fmap f (DE de) = DE $ fmap f de

stmtStructure         :: DotStatement n -> GraphState ()
stmtStructure (GA ga) = addGraphGlobals ga
stmtStructure (SG sg) = withSubGraphID addSubGraph statementStructure sg
stmtStructure _       = return ()

stmtNodes         :: (Ord n) => DotStatement n -> NodeState n ()
stmtNodes (GA ga) = addNodeGlobals ga
stmtNodes (SG sg) = withSubGraphID recursiveCall statementNodes sg
stmtNodes (DN dn) = addNode dn
stmtNodes (DE de) = addEdgeNodes de

stmtEdges         :: DotStatement n -> EdgeState n ()
stmtEdges (GA ga) = addEdgeGlobals ga
stmtEdges (SG sg) = withSubGraphID recursiveCall statementEdges sg
stmtEdges (DE de) = addEdge de
stmtEdges _       = return ()

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

data DotSubGraph n = DotSG { isCluster     :: Bool
                           , subGraphID    :: Maybe GraphID
                           , subGraphStmts :: DotStatements n
                           }
                   deriving (Eq, Ord, Show, Read)

instance (PrintDot n) => PrintDot (DotSubGraph n) where
  unqtDot = printStmtBased printSubGraphID' subGraphStmts printGStmts

  unqtListToDot = printStmtBasedList printSubGraphID' subGraphStmts printGStmts

  listToDot = unqtListToDot

printSubGraphID' :: DotSubGraph n -> DotCode
printSubGraphID' = printSubGraphID (isCluster &&& subGraphID)

instance (ParseDot n) => ParseDot (DotSubGraph n) where
  parseUnqt = parseStmtBased parseGStmts (parseSubGraphID DotSG)
              `onFail`
              -- Take anonymous DotSubGraphs into account
              liftM (DotSG False Nothing) (parseBracesBased parseGStmts)

  parse = parseUnqt -- Don't want the option of quoting
          `adjustErr`
          (++ "\n\nNot a valid Sub Graph")

  parseUnqtList = sepBy (whitespace' >> parseUnqt) newline'

  parseList = parseUnqtList

instance Functor DotSubGraph where
  fmap f sg = sg { subGraphStmts = (fmap . fmap) f $ subGraphStmts sg }

generaliseSubGraph :: C.DotSubGraph n -> DotSubGraph n
generaliseSubGraph (C.DotSG isC mID stmts) = DotSG { isCluster     = isC
                                                   , subGraphID    = mID
                                                   , subGraphStmts = stmts'
                                                   }
  where
    stmts' = generaliseStatements stmts

withSubGraphID        :: (Maybe (Maybe GraphID) -> b -> a)
                         -> (DotStatements n -> b) -> DotSubGraph n -> a
withSubGraphID f g sg = f mid . g $ subGraphStmts sg
  where
    mid = bool Nothing (Just $ subGraphID sg) $ isCluster sg

renumber    :: DotGraph n -> DotGraph n
renumber dg = dg { graphStatements = newStmts }
  where
    startN = succ $ maxSGInt dg

    newStmts = evalState (stsRe $ graphStatements dg) startN

    stsRe = T.mapM stRe
    stRe (SG sg) = liftM SG $ sgRe sg
    stRe stmt    = return stmt
    sgRe sg = do sgid' <- case subGraphID sg of
                            Nothing -> do n <- get
                                          put $ succ n
                                          return . Just $ Int n
                            sgid    -> return sgid
                 stmts' <- stsRe $ subGraphStmts sg
                 return $ sg { subGraphID    = sgid'
                             , subGraphStmts = stmts'
                             }

maxSGInt    :: DotGraph n -> Int
maxSGInt dg = execState (stsInt $ graphStatements dg)
              . flip check 0
              $ graphID dg
  where
    check = maybe id max . (numericValue =<<)

    stsInt = F.mapM_ stInt
    stInt (SG sg) = sgInt sg
    stInt _       = return ()
    sgInt sg = do modify (check $ subGraphID sg)
                  stsInt $ subGraphStmts sg