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, when)
data DotGraph a = DotGraph { strictGraph :: Bool
, directedGraph :: Bool
, graphID :: Maybe GraphID
, graphStatements :: DotStatements a
}
deriving (Eq, Ord, 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 = printIt
parseDotGraph :: (ParseDot a) => String -> DotGraph a
parseDotGraph = fst . parseIt . 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 empty strGraph' (strictGraph g)
<+> bool undirGraph' dirGraph' (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 $ parseAndSpace 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, Ord, Show, Read)
data GraphID = Str String
| Int Int
| Dbl Double
| HTML URL
deriving (Eq, Ord, 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 = liftM HTML parseUnqt
`onFail`
liftM stringNum parseUnqt
parse = liftM HTML parse
`onFail`
liftM stringNum parse
`adjustErr`
(++ "\nNot a valid GraphID")
stringNum :: String -> GraphID
stringNum str = maybe checkDbl Int $ stringToInt str
where
checkDbl = if isNumString str
then Dbl $ toDouble str
else Str str
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 [ 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, 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
unqtListToDot = printStmtBasedList printSubGraphID subGraphStmts
listToDot = unqtListToDot
printSubGraphID :: DotSubGraph a -> DotCode
printSubGraphID s = sGraph'
<+> maybe cl dtID (subGraphID s)
where
isCl = isCluster s
cl = bool empty clust' isCl
dtID = printSGID isCl
printSGID :: Bool -> GraphID -> DotCode
printSGID isCl sID = bool noClust addClust isCl
where
noClust = toDot sID
addClust = toDot . (++) clust . (:) '_'
. renderDot $ mkDot sID
mkDot (Str str) = text str
mkDot gid = unqtDot gid
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
liftM (uncurry DotSG) parseSGID
parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID = oneOf [ liftM getClustFrom $ parseAndSpace parse
, return (False, Nothing)
]
where
getClustFrom (Str str) = fst $ runParser pStr str
getClustFrom gid = (False, Just gid)
checkCl = stringRep True clust
pStr = do isCl <- checkCl
`onFail`
return False
when isCl $ optional (character '_') >> return ()
sID <- optional pID
let sID' = if sID == emptyID
then Nothing
else sID
return (isCl, sID')
emptyID = Just $ Str ""
pID = liftM HTML parseUnqt
`onFail`
liftM stringNum (many next)
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 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 ()