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
import Data.GraphViz.Util
import Data.GraphViz.Parsing
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 = printAttrBased printGlobAttrType attrs
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 = parseAttrBased parseGlobAttrType
`onFail`
liftM determineType parse `discard` optional lineEnd
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid listing of global attributes")
parseUnqtList = sepBy (whitespace' >> parse) newline'
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)
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
parseUnqtList = parseStmtBasedList parseUnqt (parseSubGraphID DotSG)
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 parse
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)
data DotEdge a = DotEdge { edgeFromNodeID :: a
, edgeToNodeID :: a
, directedEdge :: Bool
, edgeAttributes :: Attributes
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot a) => PrintDot (DotEdge a) where
unqtDot = printAttrBased printEdgeID edgeAttributes
unqtListToDot = printAttrBasedList printEdgeID edgeAttributes
listToDot = unqtListToDot
printEdgeID :: (PrintDot a) => DotEdge a -> DotCode
printEdgeID e = unqtDot (edgeFromNodeID e)
<+> bool undirEdge' dirEdge' (directedEdge e)
<+> unqtDot (edgeToNodeID e)
instance (ParseDot a) => ParseDot (DotEdge a) where
parseUnqt = parseAttrBased parseEdgeID
parse = parseUnqt
parseUnqtList = liftM concat
$ sepBy (whitespace' >> parseEdgeLine) newline'
parseList = parseUnqtList
parseEdgeID :: (ParseDot a) => Parse (Attributes -> DotEdge a)
parseEdgeID = do eHead <- parse
whitespace'
eType <- parseEdgeType
whitespace'
eTail <- parse
return $ DotEdge eHead eTail eType
parseEdgeType :: Parse Bool
parseEdgeType = stringRep True dirEdge
`onFail`
stringRep False undirEdge
parseEdgeLine :: (ParseDot a) => Parse [DotEdge a]
parseEdgeLine = liftM return parse
`onFail`
do n1 <- parse
ens <- many1 $ do whitespace'
eType <- parseEdgeType
whitespace'
n <- parse
return (eType, n)
let ens' = (True, n1) : ens
efs = zipWith mkEdg ens' (tail ens')
ef = return $ \ as -> map ($as) efs
parseAttrBased ef
where
mkEdg (_, hn) (et, tn) = DotEdge hn tn et
instance Functor DotEdge where
fmap f e = e { edgeFromNodeID = f $ edgeFromNodeID e
, edgeToNodeID = f $ edgeToNodeID e
}
dirEdge :: String
dirEdge = "->"
dirEdge' :: DotCode
dirEdge' = text dirEdge
undirEdge :: String
undirEdge = "--"
undirEdge' :: DotCode
undirEdge' = text undirEdge
invalidEdge :: DotEdge a -> [DotError a]
invalidEdge e = map (EdgeError eID)
$ filter (not . usedByEdges) (edgeAttributes e)
where
eID = Just (edgeFromNodeID e, edgeToNodeID e)
printAttrBased :: (a -> DotCode) -> (a -> Attributes) -> a -> DotCode
printAttrBased ff fas a = dc <> semi
where
f = ff a
dc = case fas a of
[] -> f
as -> f <+> toDot as
printAttrBasedList :: (a -> DotCode) -> (a -> Attributes)
-> [a] -> DotCode
printAttrBasedList ff fas = vcat . map (printAttrBased ff fas)
parseAttrBased :: Parse (Attributes -> a) -> Parse a
parseAttrBased p = do f <- p
whitespace'
atts <- tryParseList
lineEnd
return $ f atts
`adjustErr`
(++ "\n\nNot a valid attribute-based structure")
parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList p = sepBy (whitespace' >> parseAttrBased p) newline'
lineEnd :: Parse ()
lineEnd = whitespace' >> character ';' >> return ()