graphviz-2999.12.0.4: Data/GraphViz/Types/Common.hs
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
{- |
Module : Data.GraphViz.Types.Common
Description : Common internal functions for dealing with overall types.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
This module provides common functions used by both
"Data.GraphViz.Types" as well as "Data.GraphViz.Types.Generalised".
-}
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)
-- -----------------------------------------------------------------------------
-- This is re-exported by Data.GraphViz.Types
-- | A polymorphic type that covers all possible ID values allowed by
-- Dot syntax. Note that whilst the 'ParseDot' and 'PrintDot'
-- instances for 'String' will properly take care of the special
-- cases for numbers, they are treated differently here.
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`
("Not a valid GraphID\n\t"++)
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
-- -----------------------------------------------------------------------------
-- Re-exported by Data.GraphViz.Types.*
-- | Represents a list of top-level list of 'Attribute's for the
-- entire graph/sub-graph. Note that 'GraphAttrs' also applies to
-- 'DotSubGraph's.
--
-- Note that Dot allows a single 'Attribute' to be listen on a line;
-- if this is the case then when parsing, the type of 'Attribute' it
-- is determined and that type of 'GlobalAttribute' is created.
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
-- GraphAttrs, NodeAttrs and EdgeAttrs respectively
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
-- Not using parseAttrBased here because we want to force usage of
-- Attributes.
parseUnqt = do gat <- parseGlobAttrType
as <- whitespace' >> parse
return $ gat as
`onFail`
liftM determineType parse
parse = parseUnqt -- Don't want the option of quoting
`adjustErr`
("Not a valid listing of global attributes\n\t"++)
-- Have to do this manually because of the special case
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' -- Also covers SubGraph case
| usedByNodes attr = NodeAttrs attr'
| otherwise = EdgeAttrs attr' -- Must be for edges.
where
attr' = [attr]
-- -----------------------------------------------------------------------------
-- | A node in 'DotGraph'.
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 -- Don't want the option of quoting
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 () -- PortPos value
]
instance Functor DotNode where
fmap f n = n { nodeID = f $ nodeID n }
-- -----------------------------------------------------------------------------
-- This is re-exported in Data.GraphViz.Types; defined here so that
-- Generalised can access and use parseEdgeLine (needed for "a -> b ->
-- c"-style edge statements).
-- | An edge in 'DotGraph'.
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 -- Don't want the option of quoting
-- Have to take into account edges of the type "n1 -> n2 -> n3", etc.
parseUnqtList = liftM concat
$ parseStatements parseEdgeLine
parseList = parseUnqtList
parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID = do eFrom <- parseEdgeNode
-- Parse both edge types just to be more liberal
parseEdgeType
eTo <- parseEdgeNode
return $ mkEdge eFrom eTo
type EdgeNode n = (n, Maybe PortPos)
-- | Takes into account edge statements containing something like
-- @a -> \{b c\}@.
parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]
parseEdgeNodes = parseBraced ( wrapWhitespace
-- Should really use sepBy1, but this will do.
$ 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
-- -----------------------------------------------------------------------------
-- Labels
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
-- Can't use the 'braces' combinator here because we want the closing
-- brace lined up with the h value, which due to indentation might not
-- be the case with braces.
printBracesBased :: DotCode -> DotCode -> DotCode
printBracesBased h i = vcat $ sequence [ h <+> lbrace
, ind i
, rbrace
]
where
ind = indent 4
-- | This /must/ only be used for sub-graphs, etc.
parseBracesBased :: Parse a -> Parse a
parseBracesBased p = do gs <- getsGS id
a <- whitespace' >> parseBraced (wrapWhitespace p)
modifyGS (const gs)
return a
`adjustErr`
("Not a valid value wrapped in braces.\n\t"++)
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
-- | Print the actual ID for a 'DotSubGraph'.
printSGID :: Bool -> GraphID -> DotCode
printSGID isCl sID = bool noClust addClust isCl
where
noClust = toDot sID
-- Have to manually render it as we need the un-quoted form.
addClust = toDot . T.append (T.pack clust) . T.cons '_'
. renderDot $ mkDot sID
mkDot (Str str) = text str -- Quotes will be escaped later
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
-- If it's a String value, check to see if it's actually a
-- cluster_Blah value; thus need to manually re-parse it.
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 ""
-- For Strings, there are no more quotes to unescape, so consume
-- what you can.
pID = liftM stringNum $ manySatisfy (const True)
{- This is a much nicer definition, but unfortunately it doesn't work.
The problem is that Graphviz decides that a subgraph is a cluster
if the ID starts with "cluster" (no quotes); thus, we _have_ to do
the double layer of parsing to get it to work :@
do isCl <- stringRep True clust
`onFail`
return False
sID <- optional $ do when isCl
$ optional (character '_') >> return ()
parseUnqt
when (isCl || isJust sID) $ whitespace >> return ()
return (isCl, sID)
-}
-- The Bool indicates whether or not to print empty lists
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
-- The Bool indicates whether or not to print empty lists
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`
("Not a valid attribute-based structure\n\t"++)
parseAttrBasedList :: Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList = parseStatements . parseAttrBased
-- | Parse the separator (and any other whitespace present) between statements.
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