module Data.GraphViz.Types.Generalised
(
GDotGraph(..)
, GDotStatements
, GDotStatement(..)
, GDotSubGraph(..)
, GraphID(..)
, GlobalAttributes(..)
, DotNode(..)
, DotEdge(..)
, generaliseDotGraph
) where
import Data.GraphViz.Types hiding ( GraphID(..)
, GlobalAttributes(..)
, DotEdge(..))
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 Control.Arrow((&&&))
import Control.Monad(liftM)
data GDotGraph a = GDotGraph { gStrictGraph :: Bool
, gDirectedGraph :: Bool
, gGraphID :: Maybe GraphID
, gGraphStatements :: GDotStatements a
}
deriving (Eq, Ord, Show, Read)
instance (Ord n, PrintDot n, ParseDot n) => DotRepr GDotGraph n where
getID = gGraphID
graphIsDirected = gDirectedGraph
graphIsStrict = gStrictGraph
makeStrict g = g { gStrictGraph = True }
setID i g = g { gGraphID = Just i }
graphStructureInformation = getGraphInfo
. statementStructure . gGraphStatements
nodeInformation wGlobal = getNodeLookup wGlobal
. statementNodes . gGraphStatements
edgeInformation wGlobal = getDotEdges wGlobal
. statementEdges . gGraphStatements
instance (PrintDot a) => PrintDot (GDotGraph a) where
unqtDot = printStmtBased printGraphID' gGraphStatements printGStmts
where
printGraphID' = printGraphID gStrictGraph gDirectedGraph gGraphID
instance (ParseDot a) => ParseDot (GDotGraph a) where
parseUnqt = parseStmtBased parseGStmts (parseGraphID GDotGraph)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid DotGraph")
instance Functor GDotGraph where
fmap f g = g { gGraphStatements = (fmap . fmap) f $ gGraphStatements g }
generaliseDotGraph :: DotGraph a -> GDotGraph a
generaliseDotGraph dg = GDotGraph { gStrictGraph = strictGraph dg
, gDirectedGraph = directedGraph dg
, gGraphID = graphID dg
, gGraphStatements = generaliseStatements
$ graphStatements dg
}
type GDotStatements a = Seq (GDotStatement a)
printGStmts :: (PrintDot a) => GDotStatements a -> DotCode
printGStmts = toDot . F.toList
parseGStmts :: (ParseDot a) => Parse (GDotStatements a)
parseGStmts = liftM Seq.fromList parse
statementStructure :: GDotStatements a -> GraphState ()
statementStructure = F.mapM_ stmtStructure
statementNodes :: (Ord a) => GDotStatements a -> NodeState a ()
statementNodes = F.mapM_ stmtNodes
statementEdges :: GDotStatements a -> EdgeState a ()
statementEdges = F.mapM_ stmtEdges
generaliseStatements :: DotStatements a -> GDotStatements a
generaliseStatements stmts = atts >< sgs >< ns >< es
where
atts = Seq.fromList . map GA $ attrStmts stmts
sgs = Seq.fromList . map (SG . generaliseSubGraph) $ subGraphs stmts
ns = Seq.fromList . map DN $ nodeStmts stmts
es = Seq.fromList . map DE $ edgeStmts stmts
data GDotStatement a = GA GlobalAttributes
| SG (GDotSubGraph a)
| DN (DotNode a)
| DE (DotEdge a)
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (GDotStatement a) where
unqtDot (GA ga) = unqtDot ga
unqtDot (SG sg) = unqtDot sg
unqtDot (DN dn) = unqtDot dn
unqtDot (DE de) = unqtDot de
unqtListToDot = vcat . map unqtDot
listToDot = unqtListToDot
instance (ParseDot a) => ParseDot (GDotStatement a) where
parseUnqt = oneOf [ liftM GA parseUnqt
, liftM SG parseUnqt
, liftM DN parseUnqt
, liftM DE parseUnqt
]
parse = parseUnqt
`adjustErr`
(++ "Not a valid statement")
parseUnqtList = liftM concat . wrapWhitespace
$ parseStatements p
where
p = liftM (map DE) parseEdgeLine
`onFail`
liftM return parse
parseList = parseUnqtList
instance Functor GDotStatement where
fmap _ (GA ga) = GA ga
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 :: GDotStatement n -> GraphState ()
stmtStructure (GA ga) = addGraphGlobals ga
stmtStructure (SG sg) = withSubGraphID addSubGraph statementStructure sg
stmtStructure _ = return ()
stmtNodes :: (Ord a) => GDotStatement a -> NodeState a ()
stmtNodes (GA ga) = addNodeGlobals ga
stmtNodes (SG sg) = withSubGraphID recursiveCall statementNodes sg
stmtNodes (DN dn) = addNode dn
stmtNodes (DE de) = addEdgeNodes de
stmtEdges :: GDotStatement a -> EdgeState a ()
stmtEdges (GA ga) = addEdgeGlobals ga
stmtEdges (SG sg) = withSubGraphID recursiveCall statementEdges sg
stmtEdges (DE de) = addEdge de
stmtEdges _ = return ()
data GDotSubGraph a = GDotSG { gIsCluster :: Bool
, gSubGraphID :: Maybe GraphID
, gSubGraphStmts :: GDotStatements a
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (GDotSubGraph a) where
unqtDot = printStmtBased printSubGraphID' gSubGraphStmts printGStmts
unqtListToDot = printStmtBasedList printSubGraphID' gSubGraphStmts printGStmts
listToDot = unqtListToDot
printSubGraphID' :: GDotSubGraph a -> DotCode
printSubGraphID' = printSubGraphID (gIsCluster &&& gSubGraphID)
instance (ParseDot a) => ParseDot (GDotSubGraph a) where
parseUnqt = parseStmtBased parseGStmts (parseSubGraphID GDotSG)
`onFail`
liftM (GDotSG False Nothing) (parseBracesBased parseGStmts)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
parseUnqtList = sepBy (whitespace' >> parseUnqt) newline'
parseList = parseUnqtList
instance Functor GDotSubGraph where
fmap f sg = sg { gSubGraphStmts = (fmap . fmap) f $ gSubGraphStmts sg }
generaliseSubGraph :: DotSubGraph a -> GDotSubGraph a
generaliseSubGraph (DotSG isC mID stmts) = GDotSG { gIsCluster = isC
, gSubGraphID = mID
, gSubGraphStmts = stmts'
}
where
stmts' = generaliseStatements stmts
withSubGraphID :: (Maybe (Maybe GraphID) -> b -> a)
-> (GDotStatements n -> b) -> GDotSubGraph n -> a
withSubGraphID f g sg = f mid . g $ gSubGraphStmts sg
where
mid = bool Nothing (Just $ gSubGraphID sg) $ gIsCluster sg