module Data.GraphViz.Types
(
DotGraph(..)
, printDotGraph
, parseDotGraph
, setID
, makeStrict
, graphNodes
, graphEdges
, DotError(..)
, isValidGraph
, graphErrors
, GraphID(..)
, DotStatements(..)
, GlobalAttributes(..)
, DotSubGraph(..)
, DotNode(..)
, DotEdge(..)
) where
import Data.GraphViz.Attributes
import Data.GraphViz.Types.Internal
import Data.GraphViz.Types.Parsing
import Data.GraphViz.Types.Printing
import Data.Maybe(isJust)
import Control.Monad(liftM)
data DotGraph a = DotGraph { strictGraph :: Bool
, directedGraph :: Bool
, graphID :: Maybe GraphID
, graphStatements :: DotStatements a
}
deriving (Eq, Show, Read)
makeStrict :: DotGraph a -> DotGraph a
makeStrict g = g { strictGraph = True }
setID :: GraphID -> DotGraph a -> DotGraph a
setID i g = g { graphID = Just i }
graphNodes :: DotGraph a -> [DotNode a]
graphNodes = statementNodes . graphStatements
graphEdges :: DotGraph a -> [DotEdge a]
graphEdges = statementEdges . graphStatements
printDotGraph :: (PrintDot a) => DotGraph a -> String
printDotGraph = renderDot . toDot
parseDotGraph :: (ParseDot a) => String -> DotGraph a
parseDotGraph = fst . runParser parse . preprocess
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
printGraphID :: (PrintDot a) => DotGraph a -> DotCode
printGraphID g = bool strGraph' empty (strictGraph g)
<+> bool dirGraph' undirGraph' (directedGraph g)
<+> maybe empty toDot (graphID g)
instance (ParseDot a) => ParseDot (DotGraph a) where
parseUnqt = parseStmtBased parseGraphID
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid DotGraph")
parseGraphID :: (ParseDot a) => Parse (DotStatements a -> DotGraph a)
parseGraphID = do str <- liftM isJust
$ optional (parseAndSpace $ string strGraph)
dir <- parseAndSpace ( stringRep True dirGraph
`onFail`
stringRep False undirGraph
)
gID <- optional parse
return $ DotGraph str dir gID
dirGraph :: String
dirGraph = "digraph"
dirGraph' :: DotCode
dirGraph' = text dirGraph
undirGraph :: String
undirGraph = "graph"
undirGraph' :: DotCode
undirGraph' = text undirGraph
strGraph :: String
strGraph = "strict"
strGraph' :: DotCode
strGraph' = text strGraph
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, Show, Read)
data GraphID = Str String
| Int Int
| Dbl Double
| HTML URL
deriving (Eq, Show, Read)
instance PrintDot GraphID where
unqtDot (Str str) = unqtDot str
unqtDot (Int i) = unqtDot i
unqtDot (Dbl d) = unqtDot d
unqtDot (HTML u) = unqtDot u
toDot (Str str) = toDot str
toDot gID = unqtDot gID
instance ParseDot GraphID where
parseUnqt = oneOf [ liftM Str parseUnqt
, liftM Int parseUnqt
, liftM Dbl parseUnqt
, liftM HTML parseUnqt
]
parse = oneOf [ liftM Int parse
, liftM Dbl parse
, liftM HTML parse
, liftM Str parse
]
`adjustErr`
(++ "Not a valid GraphID")
data DotStatements a = DotStmts { attrStmts :: [GlobalAttributes]
, subGraphs :: [DotSubGraph a]
, nodeStmts :: [DotNode a]
, edgeStmts :: [DotEdge a]
}
deriving (Eq, Show, Read)
instance (PrintDot a) => PrintDot (DotStatements a) where
unqtDot stmts = vcat [ toDot $ attrStmts stmts
, toDot $ subGraphs stmts
, toDot $ nodeStmts stmts
, toDot $ 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
}
printStmtBased :: (PrintDot n) => (a -> DotCode)
-> (a -> DotStatements n) -> a -> DotCode
printStmtBased ff fss a = vcat [ ff a <+> lbrace
, ind stmts
, rbrace
]
where
ind = nest 4
stmts = toDot $ fss a
printStmtBasedList :: (PrintDot n) => (a -> DotCode)
-> (a -> DotStatements n) -> [a] -> DotCode
printStmtBasedList ff fss = vcat . map (printStmtBased ff fss)
parseStmtBased :: (ParseDot n) => Parse (DotStatements n -> a) -> Parse a
parseStmtBased p = do f <- p
whitespace'
character '{'
newline'
stmts <- parse
newline'
whitespace'
character '}'
return $ f stmts
`adjustErr`
(++ "\n\nNot a valid statement-based structure")
parseStmtBasedList :: (ParseDot n) => Parse (DotStatements n -> a)
-> Parse [a]
parseStmtBasedList p = sepBy (whitespace' >> parseStmtBased p) newline'
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, 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, Show, Read)
instance (PrintDot a) => PrintDot (DotSubGraph a) where
unqtDot = printStmtBased printSubGraphID subGraphStmts
unqtListToDot = printStmtBasedList printSubGraphID subGraphStmts
listToDot = unqtListToDot
printSubGraphID :: DotSubGraph a -> DotCode
printSubGraphID s = sGraph'
<+> maybe cl dtID (subGraphID s)
where
isCl = isCluster s
cl = bool clust' empty isCl
dtID = printSGID isCl
printSGID :: Bool -> GraphID -> DotCode
printSGID isCl sID = bool addClust noClust isCl
where
noClust = toDot sID
addClust = toDot . (++) clust . (:) '_'
. renderDot $ unqtDot sID
instance (ParseDot a) => ParseDot (DotSubGraph a) where
parseUnqt = parseStmtBased parseSubGraphID
parse = parseUnqt
`adjustErr`
(++ "\n\nNot a valid Sub Graph")
parseUnqtList = parseStmtBasedList parseSubGraphID
parseList = parseUnqtList
parseSubGraphID :: Parse (DotStatements a -> DotSubGraph a)
parseSubGraphID = do string sGraph
whitespace'
(isCl,sID) <- parseSGID
return $ DotSG isCl sID
parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID = do s <- parse
return (fst $ runParser pStr s)
`onFail`
liftM (flip (,) Nothing) checkCl
where
checkCl = liftM isJust $ optional (string clust)
pStr = do isCl <- checkCl `discard`optional (character '_')
sID <- parseUnqt
return (isCl, Just sID)
sGraph :: String
sGraph = "subgraph"
sGraph' :: DotCode
sGraph' = text sGraph
clust :: String
clust = "cluster"
clust' :: DotCode
clust' = text clust
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 usedByClusters usedBySubGraphs (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, 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, 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 dirEdge' undirEdge' (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 ()