{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses, OverloadedStrings #-}
module Data.GraphViz
(
GraphvizParams(..)
, quickParams
, defaultParams
, nonClusteredParams
, blankParams
, setDirectedness
, NodeCluster(..)
, LNodeCluster
, graphToDot
, graphElemsToDot
, dotToGraph
, AttributeNode
, AttributeEdge
, graphToGraph
, dotizeGraph
, EdgeID
, addEdgeIDs
, setEdgeIDAttribute
, dotAttributes
, augmentGraph
, preview
, module Data.GraphViz.Types
, module Data.GraphViz.Types.Canonical
, module Data.GraphViz.Attributes
, module Data.GraphViz.Commands
) where
import Data.GraphViz.Algorithms.Clustering
import Data.GraphViz.Attributes
import Data.GraphViz.Attributes.Complete (AttributeName, CustomAttribute,
customAttribute, customValue,
findSpecifiedCustom)
import Data.GraphViz.Commands
import Data.GraphViz.Commands.IO (hGetDot)
import Data.GraphViz.Internal.Util (uniq, uniqBy)
import Data.GraphViz.Types
import Data.GraphViz.Types.Canonical (DotGraph (..), DotStatements (..),
DotSubGraph (..))
import Data.GraphViz.Types.Generalised (FromGeneralisedDot (..))
import Control.Arrow (first, (&&&))
import Control.Concurrent (forkIO)
import Data.Graph.Inductive.Graph
import qualified Data.Map as Map
import Data.Maybe (fromJust, mapMaybe)
import qualified Data.Set as Set
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import System.IO.Unsafe (unsafePerformIO)
#if !(MIN_VERSION_base (4,8,0))
import Data.Functor ((<$>))
#endif
isUndirected :: (Ord b, Graph g) => g a b -> Bool
isUndirected :: forall b (g :: * -> * -> *) a. (Ord b, Graph g) => g a b -> Bool
isUndirected g a b
g = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Node, Node, b) -> Bool
hasFlip [(Node, Node, b)]
es
where
es :: [(Node, Node, b)]
es = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges g a b
g
eSet :: Set (Node, Node, b)
eSet = forall a. Ord a => [a] -> Set a
Set.fromList [(Node, Node, b)]
es
hasFlip :: (Node, Node, b) -> Bool
hasFlip (Node, Node, b)
e = forall a. Ord a => a -> Set a -> Bool
Set.member (forall {b} {a} {c}. (b, a, c) -> (a, b, c)
flippedEdge (Node, Node, b)
e) Set (Node, Node, b)
eSet
flippedEdge :: (b, a, c) -> (a, b, c)
flippedEdge (b
f,a
t,c
l) = (a
t,b
f,c
l)
data GraphvizParams n nl el cl l
= Params {
forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected :: Bool
, forall n nl el cl l.
GraphvizParams n nl el cl l -> [GlobalAttributes]
globalAttributes :: [GlobalAttributes]
, forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
clusterBy :: ((n,nl) -> NodeCluster cl (n,l))
, forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster :: (cl -> Bool)
, forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> GraphID
clusterID :: (cl -> GraphID)
, forall n nl el cl l.
GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster :: (cl -> [GlobalAttributes])
, forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, l) -> Attributes
fmtNode :: ((n,l) -> Attributes)
, forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge :: ((n,n,el) -> Attributes)
}
type LNodeCluster cl l = NodeCluster cl (Node,l)
quickParams :: (Labellable nl, Labellable el) => GraphvizParams n nl el () nl
quickParams :: forall nl el n.
(Labellable nl, Labellable el) =>
GraphvizParams n nl el () nl
quickParams = forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = forall {a} {a}. Labellable a => (a, a) -> Attributes
nodeFmt, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = forall {a} {a} {b}. Labellable a => (a, b, a) -> Attributes
edgeFmt }
where
nodeFmt :: (a, a) -> Attributes
nodeFmt (a
_,a
l) = [forall a. Labellable a => a -> Attribute
toLabel a
l]
edgeFmt :: (a, b, a) -> Attributes
edgeFmt (a
_,b
_,a
l) = [forall a. Labellable a => a -> Attribute
toLabel a
l]
defaultParams :: GraphvizParams n nl el cl nl
defaultParams :: forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams = Params { isDirected :: Bool
isDirected = Bool
True
, globalAttributes :: [GlobalAttributes]
globalAttributes = []
, clusterBy :: (n, nl) -> NodeCluster cl (n, nl)
clusterBy = forall c a. a -> NodeCluster c a
N
, isDotCluster :: cl -> Bool
isDotCluster = forall a b. a -> b -> a
const Bool
True
, clusterID :: cl -> GraphID
clusterID = forall a b. a -> b -> a
const (Number -> GraphID
Num forall a b. (a -> b) -> a -> b
$ Node -> Number
Int Node
0)
, fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = forall a b. a -> b -> a
const []
, fmtNode :: (n, nl) -> Attributes
fmtNode = forall a b. a -> b -> a
const []
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = forall a b. a -> b -> a
const []
}
nonClusteredParams :: GraphvizParams n nl el () nl
nonClusteredParams :: forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams = forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams
blankParams :: GraphvizParams n nl el cl l
blankParams :: forall n nl el cl l. GraphvizParams n nl el cl l
blankParams = Params { isDirected :: Bool
isDirected = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of isDirected"
, globalAttributes :: [GlobalAttributes]
globalAttributes = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of globalAttributes"
, clusterBy :: (n, nl) -> NodeCluster cl (n, l)
clusterBy = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of clusterBy"
, isDotCluster :: cl -> Bool
isDotCluster = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of isDotCluster"
, clusterID :: cl -> GraphID
clusterID = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of clusterID"
, fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtCluster"
, fmtNode :: (n, l) -> Attributes
fmtNode = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtNode"
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = forall a. HasCallStack => [Char] -> a
error [Char]
"Unspecified definition of fmtEdge"
}
setDirectedness :: (Ord el, Graph gr)
=> (GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness :: forall el (gr :: * -> * -> *) nl cl l a.
(Ord el, Graph gr) =>
(GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness GraphvizParams Node nl el cl l -> gr nl el -> a
f GraphvizParams Node nl el cl l
params gr nl el
gr = GraphvizParams Node nl el cl l -> gr nl el -> a
f GraphvizParams Node nl el cl l
params' gr nl el
gr
where
params' :: GraphvizParams Node nl el cl l
params' = GraphvizParams Node nl el cl l
params { isDirected :: Bool
isDirected = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall b (g :: * -> * -> *) a. (Ord b, Graph g) => g a b -> Bool
isUndirected gr nl el
gr }
graphToDot :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l
-> gr nl el -> DotGraph Node
graphToDot :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot GraphvizParams Node nl el cl l
params gr nl el
graph = forall cl n nl el l.
(Ord cl, Ord n) =>
GraphvizParams n nl el cl l
-> [(n, nl)] -> [(n, n, el)] -> DotGraph n
graphElemsToDot GraphvizParams Node nl el cl l
params (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
graph) (forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl el
graph)
graphElemsToDot :: (Ord cl, Ord n) => GraphvizParams n nl el cl l
-> [(n,nl)] -> [(n,n,el)] -> DotGraph n
graphElemsToDot :: forall cl n nl el l.
(Ord cl, Ord n) =>
GraphvizParams n nl el cl l
-> [(n, nl)] -> [(n, n, el)] -> DotGraph n
graphElemsToDot GraphvizParams n nl el cl l
params [(n, nl)]
lns [(n, n, el)]
les
= DotGraph { strictGraph :: Bool
strictGraph = Bool
False
, directedGraph :: Bool
directedGraph = Bool
dirGraph
, graphID :: Maybe GraphID
graphID = forall a. Maybe a
Nothing
, graphStatements :: DotStatements n
graphStatements = DotStatements n
stmts
}
where
dirGraph :: Bool
dirGraph = forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected GraphvizParams n nl el cl l
params
stmts :: DotStatements n
stmts = DotStmts { attrStmts :: [GlobalAttributes]
attrStmts = forall n nl el cl l.
GraphvizParams n nl el cl l -> [GlobalAttributes]
globalAttributes GraphvizParams n nl el cl l
params
, subGraphs :: [DotSubGraph n]
subGraphs = [DotSubGraph n]
cs
, nodeStmts :: [DotNode n]
nodeStmts = [DotNode n]
ns
, edgeStmts :: [DotEdge n]
edgeStmts = [DotEdge n]
es
}
([DotSubGraph n]
cs, [DotNode n]
ns) = forall c n a l.
Ord c =>
((n, a) -> NodeCluster c (n, l))
-> (c -> Bool)
-> (c -> GraphID)
-> (c -> [GlobalAttributes])
-> ((n, l) -> Attributes)
-> [(n, a)]
-> ([DotSubGraph n], [DotNode n])
clustersToNodes (forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
clusterBy GraphvizParams n nl el cl l
params) (forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster GraphvizParams n nl el cl l
params)
(forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> GraphID
clusterID GraphvizParams n nl el cl l
params) (forall n nl el cl l.
GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster GraphvizParams n nl el cl l
params) (forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, l) -> Attributes
fmtNode GraphvizParams n nl el cl l
params)
[(n, nl)]
lns
es :: [DotEdge n]
es = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (n, n, el) -> Maybe (DotEdge n)
mkDotEdge [(n, n, el)]
les
mkDotEdge :: (n, n, el) -> Maybe (DotEdge n)
mkDotEdge e :: (n, n, el)
e@(n
f,n
t,el
_) = if Bool
dirGraph Bool -> Bool -> Bool
|| n
f forall a. Ord a => a -> a -> Bool
<= n
t
then forall a. a -> Maybe a
Just
DotEdge { fromNode :: n
fromNode = n
f
, toNode :: n
toNode = n
t
, edgeAttributes :: Attributes
edgeAttributes = forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge GraphvizParams n nl el cl l
params (n, n, el)
e
}
else forall a. Maybe a
Nothing
dotToGraph :: (DotRepr dg Node, Graph gr) => dg Node
-> gr Attributes Attributes
dotToGraph :: forall (dg :: * -> *) (gr :: * -> * -> *).
(DotRepr dg Node, Graph gr) =>
dg Node -> gr Attributes Attributes
dotToGraph dg Node
dg = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Node, Attributes)]
ns' [(Node, Node, Attributes)]
es
where
d :: Bool
d = forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg Node
dg
ns :: [(Node, Attributes)]
ns = forall b a. Ord b => (a -> b) -> [a] -> [a]
uniqBy forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. DotNode a -> (a, Attributes)
toLN forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
es :: [(Node, Node, Attributes)]
es = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {b}. DotEdge b -> [(b, b, Attributes)]
toLE forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
nSet :: Set Node
nSet = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Node, Attributes)]
ns
nEs :: [(Node, [a])]
nEs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
uniq
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Node
nSet)
forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Node
n1,Node
n2,Attributes
_) -> [Node
n1,Node
n2]) [(Node, Node, Attributes)]
es
ns' :: [(Node, Attributes)]
ns' = [(Node, Attributes)]
ns forall a. [a] -> [a] -> [a]
++ forall {a}. [(Node, [a])]
nEs
toLN :: DotNode a -> (a, Attributes)
toLN (DotNode a
n Attributes
as) = (a
n,Attributes
as)
toLE :: DotEdge b -> [(b, b, Attributes)]
toLE (DotEdge b
f b
t Attributes
as) = (if Bool
d then forall a. a -> a
id else (:) (b
t,b
f,Attributes
as)) [(b
f,b
t,Attributes
as)]
type AttributeNode nl = (Attributes, nl)
type AttributeEdge el = (Attributes, el)
graphToGraph :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l -> gr nl el
-> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph GraphvizParams Node nl el cl l
params gr nl el
gr = forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node) =>
Bool
-> gr nl (EdgeID el)
-> dg Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes (forall n nl el cl l. GraphvizParams n nl el cl l -> Bool
isDirected GraphvizParams Node nl el cl l
params) gr nl (EdgeID el)
gr' DotGraph Node
dot
where
dot :: DotGraph Node
dot = forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot GraphvizParams Node nl (EdgeID el) cl l
params' gr nl (EdgeID el)
gr'
params' :: GraphvizParams Node nl (EdgeID el) cl l
params' = GraphvizParams Node nl el cl l
params { fmtEdge :: (Node, Node, EdgeID el) -> Attributes
fmtEdge = forall el.
(LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute forall a b. (a -> b) -> a -> b
$ forall n nl el cl l.
GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
fmtEdge GraphvizParams Node nl el cl l
params }
gr' :: gr nl (EdgeID el)
gr' = forall (gr :: * -> * -> *) nl el.
Graph gr =>
gr nl el -> gr nl (EdgeID el)
addEdgeIDs gr nl el
gr
dotizeGraph :: (Ord cl, Graph gr) => GraphvizParams Node nl el cl l
-> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)
dotizeGraph :: forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)
dotizeGraph GraphvizParams Node nl el cl l
params gr nl el
gr = forall a. IO a -> a
unsafePerformIO
forall a b. (a -> b) -> a -> b
$ forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph forall {el}. GraphvizParams Node nl el cl l
params' gr nl el
gr
where
params' :: GraphvizParams Node nl el cl l
params' = GraphvizParams Node nl el cl l
params { fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = forall a b. a -> b -> a
const []
, fmtNode :: (Node, l) -> Attributes
fmtNode = forall a b. a -> b -> a
const []
, fmtEdge :: (Node, Node, el) -> Attributes
fmtEdge = forall a b. a -> b -> a
const []
}
data EdgeID el = EID { forall el. EdgeID el -> AttributeName
eID :: Text
, forall el. EdgeID el -> el
eLbl :: el
}
deriving (EdgeID el -> EdgeID el -> Bool
forall el. Eq el => EdgeID el -> EdgeID el -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EdgeID el -> EdgeID el -> Bool
$c/= :: forall el. Eq el => EdgeID el -> EdgeID el -> Bool
== :: EdgeID el -> EdgeID el -> Bool
$c== :: forall el. Eq el => EdgeID el -> EdgeID el -> Bool
Eq, EdgeID el -> EdgeID el -> Bool
EdgeID el -> EdgeID el -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {el}. Ord el => Eq (EdgeID el)
forall el. Ord el => EdgeID el -> EdgeID el -> Bool
forall el. Ord el => EdgeID el -> EdgeID el -> Ordering
forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
min :: EdgeID el -> EdgeID el -> EdgeID el
$cmin :: forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
max :: EdgeID el -> EdgeID el -> EdgeID el
$cmax :: forall el. Ord el => EdgeID el -> EdgeID el -> EdgeID el
>= :: EdgeID el -> EdgeID el -> Bool
$c>= :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
> :: EdgeID el -> EdgeID el -> Bool
$c> :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
<= :: EdgeID el -> EdgeID el -> Bool
$c<= :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
< :: EdgeID el -> EdgeID el -> Bool
$c< :: forall el. Ord el => EdgeID el -> EdgeID el -> Bool
compare :: EdgeID el -> EdgeID el -> Ordering
$ccompare :: forall el. Ord el => EdgeID el -> EdgeID el -> Ordering
Ord, Node -> EdgeID el -> ShowS
forall el. Show el => Node -> EdgeID el -> ShowS
forall el. Show el => [EdgeID el] -> ShowS
forall el. Show el => EdgeID el -> [Char]
forall a.
(Node -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [EdgeID el] -> ShowS
$cshowList :: forall el. Show el => [EdgeID el] -> ShowS
show :: EdgeID el -> [Char]
$cshow :: forall el. Show el => EdgeID el -> [Char]
showsPrec :: Node -> EdgeID el -> ShowS
$cshowsPrec :: forall el. Show el => Node -> EdgeID el -> ShowS
Show)
addEdgeIDs :: (Graph gr) => gr nl el -> gr nl (EdgeID el)
addEdgeIDs :: forall (gr :: * -> * -> *) nl el.
Graph gr =>
gr nl el -> gr nl (EdgeID el)
addEdgeIDs gr nl el
g = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode nl]
ns [(Node, Node, EdgeID el)]
es'
where
ns :: [LNode nl]
ns = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
g
es :: [LEdge el]
es = forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl el
g
es' :: [(Node, Node, EdgeID el)]
es' = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a} {b} {el}.
Show a =>
(a, b, el) -> a -> (a, b, EdgeID el)
addID [LEdge el]
es ([Node
1..] :: [Int])
addID :: (a, b, el) -> a -> (a, b, EdgeID el)
addID (a
f,b
t,el
l) a
i = (a
f,b
t,forall el. AttributeName -> el -> EdgeID el
EID ([Char] -> AttributeName
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show a
i) el
l)
setEdgeIDAttribute :: (LEdge el -> Attributes)
-> (LEdge (EdgeID el) -> Attributes)
setEdgeIDAttribute :: forall el.
(LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute LEdge el -> Attributes
f = \ e :: LEdge (EdgeID el)
e@(Node
_,Node
_,EdgeID el
eid) -> AttributeName -> Attribute
identifierAttribute (forall el. EdgeID el -> AttributeName
eID EdgeID el
eid)
forall a. a -> [a] -> [a]
: (LEdge el -> Attributes
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall el. LEdge (EdgeID el) -> LEdge el
stripID) LEdge (EdgeID el)
e
identifierAttrName :: AttributeName
identifierAttrName :: AttributeName
identifierAttrName = AttributeName
"graphviz_distinguish_multiple_edges"
identifierAttribute :: Text -> CustomAttribute
identifierAttribute :: AttributeName -> Attribute
identifierAttribute = AttributeName -> AttributeName -> Attribute
customAttribute AttributeName
identifierAttrName
stripID :: LEdge (EdgeID el) -> LEdge el
stripID :: forall el. LEdge (EdgeID el) -> LEdge el
stripID (Node
f,Node
t,EdgeID el
eid) = (Node
f,Node
t, forall el. EdgeID el -> el
eLbl EdgeID el
eid)
dotAttributes :: (Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node)
=> Bool -> gr nl (EdgeID el)
-> dg Node -> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes :: forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, PPDotRepr dg Node, FromGeneralisedDot dg Node) =>
Bool
-> gr nl (EdgeID el)
-> dg Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes Bool
isDir gr nl (EdgeID el)
gr dg Node
dot
= forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, DotRepr dg Node) =>
gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph gr nl (EdgeID el)
gr forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotGraph Node -> dg Node
parseDG forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (dg :: * -> *) n a.
PrintDotRepr dg n =>
GraphvizCommand
-> dg n -> GraphvizOutput -> (Handle -> IO a) -> IO a
graphvizWithHandle GraphvizCommand
command dg Node
dot GraphvizOutput
DotOutput forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot
where
parseDG :: DotGraph Node -> dg Node
parseDG = (forall a. a -> a -> a
`asTypeOf` dg Node
dot) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (dg :: * -> *) n.
FromGeneralisedDot dg n =>
DotGraph n -> dg n
fromGeneralised
command :: GraphvizCommand
command = if Bool
isDir then GraphvizCommand
dirCommand else GraphvizCommand
undirCommand
augmentGraph :: (Graph gr, DotRepr dg Node) => gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph :: forall (gr :: * -> * -> *) (dg :: * -> *) nl el.
(Graph gr, DotRepr dg Node) =>
gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph gr nl (EdgeID el)
g dg Node
dg = forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [(Node, (Attributes, nl))]
lns [(Node, Node, (Attributes, el))]
les
where
lns :: [(Node, (Attributes, nl))]
lns = forall a b. (a -> b) -> [a] -> [b]
map (\(Node
n, nl
l) -> (Node
n, (Map Node Attributes
nodeMap forall k a. Ord k => Map k a -> k -> a
Map.! Node
n, nl
l)))
forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl (EdgeID el)
g
les :: [(Node, Node, (Attributes, el))]
les = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, b, EdgeID b) -> (a, b, (Attributes, b))
augmentEdge forall a b. (a -> b) -> a -> b
$ forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl (EdgeID el)
g
augmentEdge :: (a, b, EdgeID b) -> (a, b, (Attributes, b))
augmentEdge (a
f,b
t,EID AttributeName
eid b
l) = (a
f,b
t, (Map AttributeName Attributes
edgeMap forall k a. Ord k => Map k a -> k -> a
Map.! AttributeName
eid, b
l))
ns :: [DotNode Node]
ns = forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
es :: [DotEdge Node]
es = forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
nodeMap :: Map Node Attributes
nodeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall n. DotNode n -> n
nodeID forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall n. DotNode n -> Attributes
nodeAttributes) [DotNode Node]
ns
edgeMap :: Map AttributeName Attributes
edgeMap = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {n}. DotEdge n -> (AttributeName, Attributes)
edgeIDAttrs [DotEdge Node]
es
edgeIDAttrs :: DotEdge n -> (AttributeName, Attributes)
edgeIDAttrs = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Attribute -> AttributeName
customValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeName -> Attributes -> Maybe (Attribute, Attributes)
findSpecifiedCustom AttributeName
identifierAttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. DotEdge n -> Attributes
edgeAttributes
preview :: (Ord el, Graph gr, Labellable nl, Labellable el) => gr nl el -> IO ()
preview :: forall el (gr :: * -> * -> *) nl.
(Ord el, Graph gr, Labellable nl, Labellable el) =>
gr nl el -> IO ()
preview gr nl el
g = forall {a}. IO a -> IO ()
ign forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (forall {a}. IO a -> IO ()
ign forall a b. (a -> b) -> a -> b
$ forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizCanvas -> IO ()
runGraphvizCanvas' DotGraph Node
dg GraphvizCanvas
Xlib)
where
dg :: DotGraph Node
dg = forall el (gr :: * -> * -> *) nl cl l a.
(Ord el, Graph gr) =>
(GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness forall cl (gr :: * -> * -> *) nl el l.
(Ord cl, Graph gr) =>
GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot forall {n}. GraphvizParams n nl el () nl
params gr nl el
g
params :: GraphvizParams n nl el () nl
params = forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = \ (n
_,nl
l) -> [forall a. Labellable a => a -> Attribute
toLabel nl
l]
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = \ (n
_, n
_, el
l) -> [forall a. Labellable a => a -> Attribute
toLabel el
l]
}
ign :: IO a -> IO ()
ign = (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ())