{-# 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.State 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.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(when, unless) -- ----------------------------------------------------------------------------- -- 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 = stringNum <$> parseUnqt parse = 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 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 = parseBraced ( wrapWhitespace -- Should really use sepBy1, but this will do. $ parseStatements parseEdgeNode ) `onFail` fmap (:[]) 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