content: {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
  
  {- |
     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(..)
         , FromGeneralisedDot (..)
           -- * Sub-components of a @DotGraph@.
         , DotStatements
         , DotStatement(..)
         , DotSubGraph(..)
           -- * Re-exported from @Data.GraphViz.Types@.
         , GraphID(..)
         , GlobalAttributes(..)
         , DotNode(..)
         , DotEdge(..)
         ) where
  
  import           Data.GraphViz.Algorithms            (canonicalise)
  import           Data.GraphViz.Internal.State        (AttributeType(..))
  import           Data.GraphViz.Internal.Util         (bool)
  import           Data.GraphViz.Parsing
  import           Data.GraphViz.Printing
  import           Data.GraphViz.Types
  import qualified Data.GraphViz.Types.Canonical       as C
  import           Data.GraphViz.Types.Internal.Common
  import           Data.GraphViz.Types.State
  
  import           Control.Arrow       ((&&&))
  import           Control.Monad.State (evalState, execState, get, modify, put)
  import qualified Data.Foldable       as F
  import           Data.Sequence       (Seq, (><))
  import qualified Data.Sequence       as Seq
  import qualified Data.Traversable    as T
  
  -- -----------------------------------------------------------------------------
  
  -- | 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' (const GraphAttribute)
                             graphStatements printGStmts
      where
        printGraphID' = printGraphID strictGraph directedGraph graphID
  
  instance (ParseDot n) => ParseDot (DotGraph n) where
    parseUnqt = parseGraphID DotGraph
                <*> parseBracesBased GraphAttribute parseGStmts
  
    parse = parseUnqt -- Don't want the option of quoting
            `adjustErr`
            ("Not a valid generalised DotGraph\n\t"++)
  
  -- | 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
                                   }
  
  -- -----------------------------------------------------------------------------
  
  -- | This class is useful for being able to parse in a dot graph as a
  --   generalised one, and then convert it to your preferred
  --   representation.
  --
  --   This can be seen as a semi-inverse of 'fromCanonical'.
  class (DotRepr dg n) => FromGeneralisedDot dg n where
    fromGeneralised :: DotGraph n -> dg n
  
  instance (Ord n) => FromGeneralisedDot C.DotGraph n where
    fromGeneralised = canonicalise
  
  instance (Ord n) => FromGeneralisedDot DotGraph n where
    fromGeneralised = id
  
  -- -----------------------------------------------------------------------------
  
  type DotStatements n = Seq (DotStatement n)
  
  printGStmts :: (PrintDot n) => DotStatements n -> DotCode
  printGStmts = toDot . F.toList
  
  parseGStmts :: (ParseDot n) => Parse (DotStatements n)
  parseGStmts = (Seq.fromList <$> parse)
                `adjustErr`
                ("Not a valid generalised DotStatements\n\t"++)
  
  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 [ GA <$> parseUnqt
                      , SG <$> parseUnqt
                      , DN <$> parseUnqt
                      , DE <$> parseUnqt
                      ]
  
    parse = parseUnqt -- Don't want the option of quoting
            `adjustErr`
            ("Not a valid statement\n\t"++)
  
    parseUnqtList = fmap concat . wrapWhitespace
                    $ parseStatements p
      where
        -- Have to do something special here because of "a -> b -> c"
        -- syntax for edges.
        p = fmap (map DE) parseEdgeLine
            `onFail`
            fmap (:[]) 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' subGraphAttrType
                             subGraphStmts printGStmts
  
    unqtListToDot = printStmtBasedList printSubGraphID' subGraphAttrType
                                       subGraphStmts printGStmts
  
    listToDot = unqtListToDot
  
  subGraphAttrType :: DotSubGraph n -> AttributeType
  subGraphAttrType = bool SubGraphAttribute ClusterAttribute . isCluster
  
  printSubGraphID' :: DotSubGraph n -> DotCode
  printSubGraphID' = printSubGraphID (isCluster &&& subGraphID)
  
  instance (ParseDot n) => ParseDot (DotSubGraph n) where
    parseUnqt = parseSubGraph DotSG parseGStmts
                `onFail`
                -- Take anonymous DotSubGraphs into account
                fmap (DotSG False Nothing)
                     (parseBracesBased SubGraphAttribute parseGStmts)
  
    parse = parseUnqt -- Don't want the option of quoting
            `adjustErr`
            ("Not a valid Sub Graph\n\t"++)
  
    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) = SG <$> sgRe sg
      stRe stmt    = pure stmt
      sgRe sg = do sgid' <- case subGraphID sg of
                              Nothing -> do n <- get
                                            put $ succ n
                                            return . Just . Num $ 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)
                . (`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
  