module Data.GraphViz.Types.Common where
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Data.GraphViz.Util
import Data.GraphViz.Attributes.Complete( Attributes, Attribute(HeadPort, TailPort)
, usedByGraphs, usedByClusters
, usedByNodes)
import Data.GraphViz.Attributes.Internal(PortPos, parseEdgeBasedPP)
import Data.GraphViz.State(setDirectedness, getDirectedness, getsGS, modifyGS)
import Data.Maybe(isJust)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Read as T
import Data.Text.Lazy(Text)
import Control.Monad(liftM, liftM2, when)
data GraphID = Str Text
| Int Int
| Dbl Double
deriving (Eq, Ord, Show, Read)
instance PrintDot GraphID where
unqtDot (Str str) = unqtDot str
unqtDot (Int i) = unqtDot i
unqtDot (Dbl d) = unqtDot d
toDot (Str str) = toDot str
toDot gID = unqtDot gID
instance ParseDot GraphID where
parseUnqt = liftM stringNum parseUnqt
parse = liftM stringNum parse
`adjustErr`
(++ "\nNot a valid GraphID")
stringNum :: Text -> GraphID
stringNum str = maybe checkDbl Int $ stringToInt str
where
checkDbl = if isNumString str
then Dbl $ toDouble str
else Str str
numericValue :: GraphID -> Maybe Int
numericValue (Str str) = either (const Nothing) (Just . round . fst)
$ T.signed T.double str
numericValue (Int n) = Just n
numericValue (Dbl x) = Just $ round x
data GlobalAttributes = GraphAttrs { attrs :: Attributes }
| NodeAttrs { attrs :: Attributes }
| EdgeAttrs { attrs :: Attributes }
deriving (Eq, Ord, Show, Read)
instance PrintDot GlobalAttributes where
unqtDot = printAttrBased True printGlobAttrType attrs
unqtListToDot = printAttrBasedList True printGlobAttrType attrs
listToDot = unqtListToDot
partitionGlobal :: [GlobalAttributes] -> (Attributes, Attributes, Attributes)
partitionGlobal = foldr select ([], [], [])
where
select globA ~(gs,ns,es) = case globA of
GraphAttrs as -> (as ++ gs, ns, es)
NodeAttrs as -> (gs, as ++ ns, es)
EdgeAttrs as -> (gs, ns, as ++ es)
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]
data DotNode n = DotNode { nodeID :: n
, nodeAttributes :: Attributes
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot n) => PrintDot (DotNode n) where
unqtDot = printAttrBased False printNodeID nodeAttributes
unqtListToDot = printAttrBasedList False printNodeID nodeAttributes
listToDot = unqtListToDot
printNodeID :: (PrintDot n) => DotNode n -> DotCode
printNodeID = toDot . nodeID
instance (ParseDot n) => ParseDot (DotNode n) where
parseUnqt = parseAttrBased parseNodeID
parse = parseUnqt
parseUnqtList = parseAttrBasedList parseNodeID
parseList = parseUnqtList
parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n)
parseNodeID = liftM DotNode parseAndCheck
where
parseAndCheck = do n <- parse
me <- optional parseUnwanted
maybe (return n) (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 }
data DotEdge n = DotEdge { fromNode :: n
, toNode :: n
, edgeAttributes :: Attributes
}
deriving (Eq, Ord, Show, Read)
instance (PrintDot n) => PrintDot (DotEdge n) where
unqtDot = printAttrBased False printEdgeID edgeAttributes
unqtListToDot = printAttrBasedList False printEdgeID edgeAttributes
listToDot = unqtListToDot
printEdgeID :: (PrintDot n) => DotEdge n -> DotCode
printEdgeID e = do isDir <- getDirectedness
toDot (fromNode e)
<+> bool undirEdge' dirEdge' isDir
<+> toDot (toNode e)
instance (ParseDot n) => ParseDot (DotEdge n) where
parseUnqt = parseAttrBased parseEdgeID
parse = parseUnqt
parseUnqtList = liftM concat
$ parseStatements parseEdgeLine
parseList = parseUnqtList
parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID = do eFrom <- parseEdgeNode
parseEdgeType
eTo <- parseEdgeNode
return $ mkEdge eFrom eTo
type EdgeNode n = (n, Maybe PortPos)
parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]
parseEdgeNodes = parseBraced ( wrapWhitespace
$ parseStatements parseEdgeNode
)
`onFail`
liftM return parseEdgeNode
parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n)
parseEdgeNode = liftM2 (,) parse
(optional $ character ':' >> parseEdgeBasedPP)
mkEdge :: EdgeNode n -> EdgeNode n -> Attributes -> DotEdge n
mkEdge (eFrom, mFP) (eTo, mTP) = DotEdge eFrom eTo
. addPortPos TailPort mFP
. addPortPos HeadPort mTP
mkEdges :: [EdgeNode n] -> [EdgeNode n]
-> Attributes -> [DotEdge n]
mkEdges fs ts as = liftM2 (\f t -> mkEdge f t as) fs ts
addPortPos :: (PortPos -> Attribute) -> Maybe PortPos
-> Attributes -> Attributes
addPortPos c = maybe id ((:) . c)
parseEdgeType :: Parse Bool
parseEdgeType = wrapWhitespace $ stringRep True dirEdge
`onFail`
stringRep False undirEdge
parseEdgeLine :: (ParseDot n) => Parse [DotEdge n]
parseEdgeLine = do n1 <- parseEdgeNodes
ens <- many1 $ do parseEdgeType
parseEdgeNodes
let ens' = n1 : ens
efs = zipWith mkEdges ens' (tail ens')
ef = return $ \ as -> concatMap ($as) efs
parseAttrBased ef
instance Functor DotEdge where
fmap f e = e { fromNode = f $ fromNode e
, toNode = f $ toNode e
}
dirEdge :: String
dirEdge = "->"
dirEdge' :: DotCode
dirEdge' = text $ T.pack dirEdge
undirEdge :: String
undirEdge = "--"
undirEdge' :: DotCode
undirEdge' = text $ T.pack undirEdge
dirGraph :: String
dirGraph = "digraph"
dirGraph' :: DotCode
dirGraph' = text $ T.pack dirGraph
undirGraph :: String
undirGraph = "graph"
undirGraph' :: DotCode
undirGraph' = text $ T.pack undirGraph
strGraph :: String
strGraph = "strict"
strGraph' :: DotCode
strGraph' = text $ T.pack strGraph
sGraph :: String
sGraph = "subgraph"
sGraph' :: DotCode
sGraph' = text $ T.pack sGraph
clust :: String
clust = "cluster"
clust' :: DotCode
clust' = text $ T.pack clust
printGraphID :: (a -> Bool) -> (a -> Bool)
-> (a -> Maybe GraphID)
-> a -> DotCode
printGraphID str isDir mID g = do setDirectedness isDir'
bool empty strGraph' (str g)
<+> bool undirGraph' dirGraph' isDir'
<+> maybe empty toDot (mID g)
where
isDir' = isDir g
parseGraphID :: (Bool -> Bool -> Maybe GraphID -> a) -> Parse a
parseGraphID f = do allWhitespace'
str <- liftM isJust
$ optional (parseAndSpace $ string strGraph)
dir <- parseAndSpace ( stringRep True dirGraph
`onFail`
stringRep False undirGraph
)
setDirectedness dir
gID <- optional $ parseAndSpace parse
return $ f str dir gID
printStmtBased :: (a -> DotCode) -> (a -> b) -> (b -> DotCode)
-> a -> DotCode
printStmtBased f r dr a = do gs <- getsGS id
dc <- printBracesBased (f a) (dr $ r a)
modifyGS (const gs)
return dc
printStmtBasedList :: (a -> DotCode) -> (a -> b) -> (b -> DotCode)
-> [a] -> DotCode
printStmtBasedList f r dr = vcat . mapM (printStmtBased f r dr)
parseStmtBased :: Parse stmt -> Parse (stmt -> a) -> Parse a
parseStmtBased = flip apply . parseBracesBased
printBracesBased :: DotCode -> DotCode -> DotCode
printBracesBased h i = vcat $ sequence [ h <+> lbrace
, ind i
, rbrace
]
where
ind = indent 4
parseBracesBased :: Parse a -> Parse a
parseBracesBased p = do gs <- getsGS id
a <- whitespace' >> parseBraced (wrapWhitespace p)
modifyGS (const gs)
return a
`adjustErr`
(++ "\nNot a valid value wrapped in braces.")
printSubGraphID :: (a -> (Bool, Maybe GraphID)) -> a -> DotCode
printSubGraphID f a = sGraph'
<+> maybe cl dtID mID
where
(isCl, mID) = f a
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 . T.append (T.pack clust) . T.cons '_'
. renderDot $ mkDot sID
mkDot (Str str) = text str
mkDot gid = unqtDot gid
parseSubGraphID :: (Bool -> Maybe GraphID -> c) -> Parse c
parseSubGraphID f = do string sGraph
whitespace
liftM (uncurry f) parseSGID
parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID = oneOf [ liftM getClustFrom $ parseAndSpace parse
, return (False, Nothing)
]
where
getClustFrom (Str str) = 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 stringNum $ manySatisfy (const True)
printAttrBased :: Bool -> (a -> DotCode) -> (a -> Attributes)
-> a -> DotCode
printAttrBased prEmp ff fas a = dc <> semi
where
f = ff a
dc = case fas a of
[] | not prEmp -> f
as -> f <+> toDot as
printAttrBasedList :: Bool -> (a -> DotCode) -> (a -> Attributes)
-> [a] -> DotCode
printAttrBasedList prEmp ff fas = vcat . mapM (printAttrBased prEmp ff fas)
parseAttrBased :: Parse (Attributes -> a) -> Parse a
parseAttrBased p = do f <- p
atts <- tryParseList' (whitespace' >> parse)
return $ f atts
`adjustErr`
(++ "\n\nNot a valid attribute-based structure")
parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList = parseStatements . parseAttrBased
statementEnd :: Parse ()
statementEnd = parseSplit >> newline'
where
parseSplit = (whitespace' >> oneOf [ character ';' >> return ()
, newline
]
)
`onFail`
whitespace
parseStatements :: Parse a -> Parse [a]
parseStatements p = sepBy (whitespace' >> p) statementEnd
`discard`
optional statementEnd