graphviz-2999.18.0.2: Data/GraphViz/Types/Internal/Common.hs
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK hide #-}
{- |
Module : Data.GraphViz.Types.Internal.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.Internal.Common
( GraphID (..)
, Number (..)
, numericValue
, GlobalAttributes (..)
, partitionGlobal
, unPartitionGlobal
, withGlob
, DotNode (..)
, DotEdge (..)
, parseEdgeLine
, printGraphID
, parseGraphID
, printStmtBased
, printStmtBasedList
, printSubGraphID
, parseSubGraph
, parseBracesBased
, parseStatements
) where
import Data.GraphViz.Attributes.Complete (Attribute (HeadPort, TailPort),
Attributes, Number (..),
usedByClusters, usedByGraphs,
usedByNodes)
import Data.GraphViz.Attributes.Internal (PortPos, parseEdgeBasedPP)
import Data.GraphViz.Internal.State
import Data.GraphViz.Internal.Util
import Data.GraphViz.Parsing
import Data.GraphViz.Printing
import Control.Monad (unless, when)
import Data.Maybe (isJust)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Read as T
-- -----------------------------------------------------------------------------
-- 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
| Num Number
deriving (Eq, Ord, Show, Read)
instance PrintDot GraphID where
unqtDot (Str str) = unqtDot str
unqtDot (Num n) = unqtDot n
toDot (Str str) = toDot str
toDot (Num n) = toDot n
instance ParseDot GraphID where
parseUnqt = stringNum <$> parseUnqt
parse = stringNum <$> parse
`adjustErr`
("Not a valid GraphID\n\t"++)
stringNum :: Text -> GraphID
stringNum str = maybe checkDbl (Num . Int) $ stringToInt str
where
checkDbl = if isNumString str
then Num . 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 (Num n) = case n of
Int i -> Just i
Dbl d -> Just $ round d
-- -----------------------------------------------------------------------------
-- 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 listed 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 globAttrType attrs
unqtListToDot = printAttrBasedList True printGlobAttrType globAttrType 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)
unPartitionGlobal :: (Attributes, Attributes, Attributes) -> [GlobalAttributes]
unPartitionGlobal (gas,nas,eas) = [ GraphAttrs gas
, NodeAttrs nas
, EdgeAttrs eas
]
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
-- Determine if we need to set the attribute type.
let mtp = globAttrType $ gat [] -- Only need the constructor
oldTp <- getAttributeType
maybe (return ()) setAttributeType mtp
as <- whitespace *> parse
-- Safe to set back even if not changed.
setAttributeType oldTp
return $ gat as
`onFail`
fmap 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 parseUnqt
parseList = parseUnqtList
-- Cheat: rather than determine whether it's a graph, cluster or
-- sub-graph just don't set it.
globAttrType :: GlobalAttributes -> Maybe AttributeType
globAttrType NodeAttrs{} = Just NodeAttribute
globAttrType EdgeAttrs{} = Just EdgeAttribute
globAttrType _ = Nothing
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]
withGlob :: (Attributes -> Attributes) -> GlobalAttributes -> GlobalAttributes
withGlob f (GraphAttrs as) = GraphAttrs $ f as
withGlob f (NodeAttrs as) = NodeAttrs $ f as
withGlob f (EdgeAttrs as) = EdgeAttrs $ f as
-- -----------------------------------------------------------------------------
-- | 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
(const $ Just NodeAttribute) nodeAttributes
unqtListToDot = printAttrBasedList False printNodeID
(const $ Just NodeAttribute) nodeAttributes
listToDot = unqtListToDot
printNodeID :: (PrintDot n) => DotNode n -> DotCode
printNodeID = toDot . nodeID
instance (ParseDot n) => ParseDot (DotNode n) where
parseUnqt = parseAttrBased NodeAttribute False parseNodeID
parse = parseUnqt -- Don't want the option of quoting
parseUnqtList = parseAttrBasedList NodeAttribute False parseNodeID
parseList = parseUnqtList
parseNodeID :: (ParseDot n) => Parse (Attributes -> DotNode n)
parseNodeID = 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
(const $ Just EdgeAttribute) edgeAttributes
unqtListToDot = printAttrBasedList False printEdgeID
(const $ Just EdgeAttribute) 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 EdgeAttribute False parseEdgeID
parse = parseUnqt -- Don't want the option of quoting
-- Have to take into account edges of the type "n1 -> n2 -> n3", etc.
parseUnqtList = concat <$> parseStatements parseEdgeLine
parseList = parseUnqtList
parseEdgeID :: (ParseDot n) => Parse (Attributes -> DotEdge n)
parseEdgeID = ignoreSep mkEdge parseEdgeNode parseEdgeType parseEdgeNode
`adjustErr`
("Parsed beginning of DotEdge but could not parse Attributes:\n\t"++)
-- Parse both edge types just to be more liberal
type EdgeNode n = (n, Maybe PortPos)
-- | Takes into account edge statements containing something like
-- @a -> \{b c\}@.
parseEdgeNodes :: (ParseDot n) => Parse [EdgeNode n]
parseEdgeNodes = oneOf [ parseBraced (wrapWhitespace
-- Should really use sepBy1, but this will do.
$ parseStatements parseEdgeNode)
, wrapWhitespace (sepBy1 parseEdgeNode (wrapWhitespace parseComma))
, (: []) <$> parseEdgeNode ]
parseEdgeNode :: (ParseDot n) => Parse (EdgeNode n)
parseEdgeNode = liftA2 (,) 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 = liftA2 (\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 $ parseEdgeType *> parseEdgeNodes
let ens' = n1 : ens
efs = zipWith mkEdges ens' (tail ens')
ef = return $ \ as -> concatMap ($as) efs
parseAttrBased EdgeAttribute False 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 whitespace
str <- 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 -> AttributeType)
-> (a -> stmts) -> (stmts -> DotCode)
-> a -> DotCode
printStmtBased f ftp r dr a = do gs <- getsGS id
setAttributeType $ ftp a
dc <- printBracesBased (f a) (dr $ r a)
modifyGS (const gs)
return dc
printStmtBasedList :: (a -> DotCode) -> (a -> AttributeType)
-> (a -> stmts) -> (stmts -> DotCode)
-> [a] -> DotCode
printStmtBasedList f ftp r dr = vcat . mapM (printStmtBased f ftp r dr)
-- 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 :: AttributeType -> Parse a -> Parse a
parseBracesBased tp p = do gs <- getsGS id
setAttributeType tp
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
parseSubGraph :: (Bool -> Maybe GraphID -> stmt -> c) -> Parse stmt -> Parse c
parseSubGraph pid pst = do (isC, fID) <- parseSubGraphID pid
let tp = bool SubGraphAttribute ClusterAttribute isC
fID <$> parseBracesBased tp pst
parseSubGraphID :: (Bool -> Maybe GraphID -> c) -> Parse (Bool,c)
parseSubGraphID f = appl <$> (string sGraph *> whitespace1 *> parseSGID)
where
appl (isC, mid) = (isC, f isC mid)
parseSGID :: Parse (Bool, Maybe GraphID)
parseSGID = oneOf [ 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 = 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) $ whitespace1 *> return ()
return (isCl, sID)
-}
-- The Bool is True for global, False for local.
printAttrBased :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
-> (a -> Attributes) -> a -> DotCode
printAttrBased prEmp ff ftp fas a = do oldType <- getAttributeType
maybe (return ()) setAttributeType mtp
oldCS <- getColorScheme
(dc <> semi) <* unless prEmp (setColorScheme oldCS)
<* setAttributeType oldType
where
mtp = ftp a
f = ff a
dc = case fas a of
[] | not prEmp -> f
as -> f <+> toDot as
-- The Bool is True for global, False for local.
printAttrBasedList :: Bool -> (a -> DotCode) -> (a -> Maybe AttributeType)
-> (a -> Attributes) -> [a] -> DotCode
printAttrBasedList prEmp ff ftp fas = vcat . mapM (printAttrBased prEmp ff ftp fas)
-- The Bool is True for global, False for local.
parseAttrBased :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse a
parseAttrBased tp lc p = do oldType <- getAttributeType
setAttributeType tp
oldCS <- getColorScheme
f <- p
atts <- tryParseList' (whitespace *> parse)
unless lc $ setColorScheme oldCS
when (tp /= oldType) $ setAttributeType oldType
return $ f atts
`adjustErr`
("Not a valid attribute-based structure\n\t"++)
-- The Bool is True for global, False for local.
parseAttrBasedList :: AttributeType -> Bool -> Parse (Attributes -> a) -> Parse [a]
parseAttrBasedList tp lc = parseStatements . parseAttrBased tp lc
-- | Parse the separator (and any other whitespace1 present) between statements.
statementEnd :: Parse ()
statementEnd = parseSplit *> newline'
where
parseSplit = (whitespace *> oneOf [ character ';' *> return ()
, newline
]
)
`onFail`
whitespace1
parseStatements :: Parse a -> Parse [a]
parseStatements p = sepBy (whitespace *> p) statementEnd
`discard`
optional statementEnd