module Data.GraphViz.Types.Generalised
(
GDotGraph(..)
, GDotStatements
, GDotStatement(..)
, GDotSubGraph(..)
, GraphID(..)
, GlobalAttributes(..)
, DotNode(..)
, DotEdge(..)
, generaliseDotGraph
) where
import Data.GraphViz.Types hiding (GraphID(..))
import Data.GraphViz.Types.Common
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import qualified Data.Sequence as Seq
import Data.Sequence(Seq, (><))
import qualified Data.Foldable as F
import Control.Monad(liftM)
data GDotGraph a = GDotGraph { gStrictGraph :: Bool
, gDirectedGraph :: Bool
, gGraphID :: Maybe GraphID
, gGraphStatements :: GDotStatements a
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot n, ParseDot n) => DotRepr GDotGraph n where
graphIsDirected = gDirectedGraph
makeStrict g = g { gStrictGraph = True }
setID i g = g { gGraphID = Just i }
graphNodes = statementNodes . gGraphStatements
graphEdges = 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 = vcat . map toDot . F.toList
parseGStmts :: (ParseDot a) => Parse (GDotStatements a)
parseGStmts = liftM Seq.fromList $ many p
where
p = whitespace' >> parse `discard` newline'
statementNodes :: GDotStatements a -> [DotNode a]
statementNodes = concatMap stmtNodes . F.toList
statementEdges :: GDotStatements a -> [DotEdge a]
statementEdges = concatMap stmtEdges . F.toList
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
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")
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
stmtNodes :: GDotStatement a -> [DotNode a]
stmtNodes (SG sg) = subGraphNodes sg
stmtNodes (DN dn) = [dn]
stmtNodes _ = []
stmtEdges :: (GDotStatement a) -> [DotEdge a]
stmtEdges (SG sg) = subGraphEdges sg
stmtEdges (DE de) = [de]
stmtEdges _ = []
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 (\sg -> (gIsCluster sg, gSubGraphID sg))
instance (ParseDot a) => ParseDot (GDotSubGraph a) where
parseUnqt = parseStmtBased parseGStmts (parseSubGraphID GDotSG)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
parseUnqtList = parseStmtBasedList parseGStmts (parseSubGraphID GDotSG)
parseList = parseUnqtList
instance Functor GDotSubGraph where
fmap f sg = sg { gSubGraphStmts = (fmap . fmap) f $ gSubGraphStmts sg }
subGraphNodes :: GDotSubGraph a -> [DotNode a]
subGraphNodes = statementNodes . gSubGraphStmts
subGraphEdges :: GDotSubGraph a -> [DotEdge a]
subGraphEdges = statementEdges . gSubGraphStmts
generaliseSubGraph :: DotSubGraph a -> GDotSubGraph a
generaliseSubGraph (DotSG isC mID stmts) = GDotSG { gIsCluster = isC
, gSubGraphID = mID
, gSubGraphStmts = stmts'
}
where
stmts' = generaliseStatements stmts