module Data.GraphViz.Types
(
DotRepr(..)
, printDotGraph
, parseDotGraph
, DotGraph(..)
, DotError(..)
, isValidGraph
, graphErrors
, GraphID(..)
, DotStatements(..)
, GlobalAttributes(..)
, DotSubGraph(..)
, DotNode(..)
, DotEdge(..)
) where
import Data.GraphViz.Types.Common
import Data.GraphViz.Attributes( Attributes, Attribute
, usedByGraphs, usedByClusters, usedBySubGraphs
, usedByNodes, usedByEdges)
import Data.GraphViz.Util
import Data.GraphViz.Parsing
import Data.GraphViz.PreProcessing
import Data.GraphViz.Printing
import Control.Monad(liftM)
class (PrintDot (dg n), ParseDot (dg n)) => DotRepr dg n where
graphIsDirected :: dg n -> Bool
makeStrict :: dg n -> dg n
setID :: GraphID -> dg n -> dg n
graphNodes :: dg n -> [DotNode n]
graphEdges :: dg n -> [DotEdge n]
printDotGraph :: (DotRepr dg n) => dg n -> String
printDotGraph = printIt
parseDotGraph :: (DotRepr dg n) => String -> dg n
parseDotGraph = fst . parseIt . preProcess
data DotGraph a = DotGraph { strictGraph :: Bool
, directedGraph :: Bool
, graphID :: Maybe GraphID
, graphStatements :: DotStatements a
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot n, ParseDot n) => DotRepr DotGraph n where
graphIsDirected = directedGraph
makeStrict g = g { strictGraph = True }
setID i g = g { graphID = Just i }
graphNodes = statementNodes . graphStatements
graphEdges = statementEdges . graphStatements
isValidGraph :: DotGraph a -> Bool
isValidGraph = null . graphErrors
graphErrors :: DotGraph a -> [DotError a]
graphErrors = invalidStmts usedByGraphs . graphStatements
instance (PrintDot a) => PrintDot (DotGraph a) where
unqtDot = printStmtBased printGraphID' graphStatements toDot
where
printGraphID' = printGraphID strictGraph directedGraph graphID
instance (ParseDot a) => ParseDot (DotGraph a) where
parseUnqt = parseStmtBased parse (parseGraphID DotGraph)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid DotGraph")
instance Functor DotGraph where
fmap f g = g { graphStatements = fmap f $ graphStatements g }
data DotError a = GraphError Attribute
| NodeError (Maybe a) Attribute
| EdgeError (Maybe (a,a)) Attribute
deriving (Eq, Ord, Show, Read)
data DotStatements a = DotStmts { attrStmts :: [GlobalAttributes]
, subGraphs :: [DotSubGraph a]
, nodeStmts :: [DotNode a]
, edgeStmts :: [DotEdge a]
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotStatements a) where
unqtDot stmts = vcat [ unqtDot $ attrStmts stmts
, unqtDot $ subGraphs stmts
, unqtDot $ nodeStmts stmts
, unqtDot $ edgeStmts stmts
]
instance (ParseDot a) => ParseDot (DotStatements a) where
parseUnqt = do atts <- tryParseList
newline'
sGraphs <- tryParseList
newline'
nodes <- tryParseList
newline'
edges <- tryParseList
return $ DotStmts atts sGraphs nodes edges
parse = parseUnqt
`adjustErr`
(++ "Not a valid set of statements")
instance Functor DotStatements where
fmap f stmts = stmts { subGraphs = map (fmap f) $ subGraphs stmts
, nodeStmts = map (fmap f) $ nodeStmts stmts
, edgeStmts = map (fmap f) $ edgeStmts stmts
}
invalidStmts :: (Attribute -> Bool) -> DotStatements a -> [DotError a]
invalidStmts f stmts = concatMap (invalidGlobal f) (attrStmts stmts)
++ concatMap invalidSubGraph (subGraphs stmts)
++ concatMap invalidNode (nodeStmts stmts)
++ concatMap invalidEdge (edgeStmts stmts)
statementNodes :: DotStatements a -> [DotNode a]
statementNodes stmts = concatMap subGraphNodes (subGraphs stmts)
++ nodeStmts stmts
statementEdges :: DotStatements a -> [DotEdge a]
statementEdges stmts = concatMap subGraphEdges (subGraphs stmts)
++ edgeStmts stmts
data GlobalAttributes = GraphAttrs { attrs :: Attributes }
| NodeAttrs { attrs :: Attributes }
| EdgeAttrs { attrs :: Attributes }
deriving (Eq, Ord, Show, Read)
instance PrintDot GlobalAttributes where
unqtDot ga = printGlobAttrType ga <+> toDot (attrs ga) <> semi
unqtListToDot = printAttrBasedList printGlobAttrType attrs
listToDot = unqtListToDot
printGlobAttrType :: GlobalAttributes -> DotCode
printGlobAttrType GraphAttrs{} = text "graph"
printGlobAttrType NodeAttrs{} = text "node"
printGlobAttrType EdgeAttrs{} = text "edge"
instance ParseDot GlobalAttributes where
parseUnqt = do gat <- parseGlobAttrType
as <- whitespace' >> parse
return $ gat as
`onFail`
liftM determineType parse
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid listing of global attributes")
parseUnqtList = parseStatements parse
parseList = parseUnqtList
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'
| usedByNodes attr = NodeAttrs attr'
| otherwise = EdgeAttrs attr'
where
attr' = [attr]
invalidGlobal :: (Attribute -> Bool) -> GlobalAttributes
-> [DotError a]
invalidGlobal f (GraphAttrs as) = map GraphError $ filter (not . f) as
invalidGlobal _ (NodeAttrs as) = map (NodeError Nothing)
$ filter (not . usedByNodes) as
invalidGlobal _ (EdgeAttrs as) = map (EdgeError Nothing)
$ filter (not . usedByEdges) as
data DotSubGraph a = DotSG { isCluster :: Bool
, subGraphID :: Maybe GraphID
, subGraphStmts :: DotStatements a
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotSubGraph a) where
unqtDot = printStmtBased printSubGraphID' subGraphStmts toDot
unqtListToDot = printStmtBasedList printSubGraphID' subGraphStmts toDot
listToDot = unqtListToDot
printSubGraphID' :: DotSubGraph a -> DotCode
printSubGraphID' = printSubGraphID (\sg -> (isCluster sg, subGraphID sg))
instance (ParseDot a) => ParseDot (DotSubGraph a) where
parseUnqt = parseStmtBased parseUnqt (parseSubGraphID DotSG)
`onFail`
liftM (DotSG False Nothing) (parseBracesBased parseUnqt)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
parseUnqtList = sepBy (whitespace' >> parseUnqt) newline'
parseList = parseUnqtList
instance Functor DotSubGraph where
fmap f sg = sg { subGraphStmts = fmap f $ subGraphStmts sg }
invalidSubGraph :: DotSubGraph a -> [DotError a]
invalidSubGraph sg = invalidStmts valFunc (subGraphStmts sg)
where
valFunc = bool usedBySubGraphs usedByClusters (isCluster sg)
subGraphNodes :: DotSubGraph a -> [DotNode a]
subGraphNodes = statementNodes . subGraphStmts
subGraphEdges :: DotSubGraph a -> [DotEdge a]
subGraphEdges = statementEdges . subGraphStmts
data DotNode a = DotNode { nodeID :: a
, nodeAttributes :: Attributes
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotNode a) where
unqtDot = printAttrBased printNodeID nodeAttributes
unqtListToDot = printAttrBasedList printNodeID nodeAttributes
listToDot = unqtListToDot
printNodeID :: (PrintDot a) => DotNode a -> DotCode
printNodeID = toDot . nodeID
instance (ParseDot a) => ParseDot (DotNode a) where
parseUnqt = parseAttrBased parseNodeID
parse = parseUnqt
parseUnqtList = parseAttrBasedList parseNodeID
parseList = parseUnqtList
parseNodeID :: (ParseDot a) => Parse (Attributes -> DotNode a)
parseNodeID = liftM DotNode parseAndCheck
where
parseAndCheck = do a <- parse
me <- optional parseUnwanted
maybe (return a) (const notANode) me
notANode = fail "This appears to be an edge, not a node"
parseUnwanted = oneOf [ parseEdgeType >> return ()
, character ':' >> return ()
]
instance Functor DotNode where
fmap f n = n { nodeID = f $ nodeID n }
invalidNode :: DotNode a -> [DotError a]
invalidNode n = map (NodeError (Just $ nodeID n))
$ filter (not . usedByNodes) (nodeAttributes n)
invalidEdge :: DotEdge a -> [DotError a]
invalidEdge e = map (EdgeError eID)
$ filter (not . usedByEdges) (edgeAttributes e)
where
eID = Just (edgeFromNodeID e, edgeToNodeID e)