{-# 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 :: g a b -> Bool
isUndirected g :: g a b
g = ((Node, Node, b) -> Bool) -> [(Node, Node, b)] -> Bool
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 = g a b -> [(Node, Node, b)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges g a b
g
eSet :: Set (Node, Node, b)
eSet = [(Node, Node, b)] -> Set (Node, Node, b)
forall a. Ord a => [a] -> Set a
Set.fromList [(Node, Node, b)]
es
hasFlip :: (Node, Node, b) -> Bool
hasFlip e :: (Node, Node, b)
e = (Node, Node, b) -> Set (Node, Node, b) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ((Node, Node, b) -> (Node, Node, b)
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 (f :: b
f,t :: a
t,l :: c
l) = (a
t,b
f,c
l)
data GraphvizParams n nl el cl l
= Params {
GraphvizParams n nl el cl l -> Bool
isDirected :: Bool
, GraphvizParams n nl el cl l -> [GlobalAttributes]
globalAttributes :: [GlobalAttributes]
, GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
clusterBy :: ((n,nl) -> NodeCluster cl (n,l))
, GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster :: (cl -> Bool)
, GraphvizParams n nl el cl l -> cl -> GraphID
clusterID :: (cl -> GraphID)
, GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster :: (cl -> [GlobalAttributes])
, GraphvizParams n nl el cl l -> (n, l) -> Attributes
fmtNode :: ((n,l) -> Attributes)
, 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 :: GraphvizParams n nl el () nl
quickParams = GraphvizParams n nl Any () nl
forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = (n, nl) -> Attributes
forall a a. Labellable a => (a, a) -> Attributes
nodeFmt, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = (n, n, el) -> Attributes
forall a a b. Labellable a => (a, b, a) -> Attributes
edgeFmt }
where
nodeFmt :: (a, a) -> Attributes
nodeFmt (_,l :: a
l) = [a -> Attribute
forall a. Labellable a => a -> Attribute
toLabel a
l]
edgeFmt :: (a, b, a) -> Attributes
edgeFmt (_,_,l :: a
l) = [a -> Attribute
forall a. Labellable a => a -> Attribute
toLabel a
l]
defaultParams :: GraphvizParams n nl el cl nl
defaultParams :: GraphvizParams n nl el cl nl
defaultParams = Params :: forall n nl el cl l.
Bool
-> [GlobalAttributes]
-> ((n, nl) -> NodeCluster cl (n, l))
-> (cl -> Bool)
-> (cl -> GraphID)
-> (cl -> [GlobalAttributes])
-> ((n, l) -> Attributes)
-> ((n, n, el) -> Attributes)
-> GraphvizParams n nl el cl l
Params { isDirected :: Bool
isDirected = Bool
True
, globalAttributes :: [GlobalAttributes]
globalAttributes = []
, clusterBy :: (n, nl) -> NodeCluster cl (n, nl)
clusterBy = (n, nl) -> NodeCluster cl (n, nl)
forall c a. a -> NodeCluster c a
N
, isDotCluster :: cl -> Bool
isDotCluster = Bool -> cl -> Bool
forall a b. a -> b -> a
const Bool
True
, clusterID :: cl -> GraphID
clusterID = GraphID -> cl -> GraphID
forall a b. a -> b -> a
const (Number -> GraphID
Num (Number -> GraphID) -> Number -> GraphID
forall a b. (a -> b) -> a -> b
$ Node -> Number
Int 0)
, fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = [GlobalAttributes] -> cl -> [GlobalAttributes]
forall a b. a -> b -> a
const []
, fmtNode :: (n, nl) -> Attributes
fmtNode = Attributes -> (n, nl) -> Attributes
forall a b. a -> b -> a
const []
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = Attributes -> (n, n, el) -> Attributes
forall a b. a -> b -> a
const []
}
nonClusteredParams :: GraphvizParams n nl el () nl
nonClusteredParams :: GraphvizParams n nl el () nl
nonClusteredParams = GraphvizParams n nl el () nl
forall n nl el cl. GraphvizParams n nl el cl nl
defaultParams
blankParams :: GraphvizParams n nl el cl l
blankParams :: GraphvizParams n nl el cl l
blankParams = Params :: forall n nl el cl l.
Bool
-> [GlobalAttributes]
-> ((n, nl) -> NodeCluster cl (n, l))
-> (cl -> Bool)
-> (cl -> GraphID)
-> (cl -> [GlobalAttributes])
-> ((n, l) -> Attributes)
-> ((n, n, el) -> Attributes)
-> GraphvizParams n nl el cl l
Params { isDirected :: Bool
isDirected = [Char] -> Bool
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of isDirected"
, globalAttributes :: [GlobalAttributes]
globalAttributes = [Char] -> [GlobalAttributes]
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of globalAttributes"
, clusterBy :: (n, nl) -> NodeCluster cl (n, l)
clusterBy = [Char] -> (n, nl) -> NodeCluster cl (n, l)
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of clusterBy"
, isDotCluster :: cl -> Bool
isDotCluster = [Char] -> cl -> Bool
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of isDotCluster"
, clusterID :: cl -> GraphID
clusterID = [Char] -> cl -> GraphID
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of clusterID"
, fmtCluster :: cl -> [GlobalAttributes]
fmtCluster = [Char] -> cl -> [GlobalAttributes]
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of fmtCluster"
, fmtNode :: (n, l) -> Attributes
fmtNode = [Char] -> (n, l) -> Attributes
forall a. HasCallStack => [Char] -> a
error "Unspecified definition of fmtNode"
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = [Char] -> (n, n, el) -> Attributes
forall a. HasCallStack => [Char] -> a
error "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 :: (GraphvizParams Node nl el cl l -> gr nl el -> a)
-> GraphvizParams Node nl el cl l -> gr nl el -> a
setDirectedness f :: GraphvizParams Node nl el cl l -> gr nl el -> a
f params :: GraphvizParams Node nl el cl l
params gr :: 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ gr nl el -> Bool
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 :: GraphvizParams Node nl el cl l -> gr nl el -> DotGraph Node
graphToDot params :: GraphvizParams Node nl el cl l
params graph :: gr nl el
graph = GraphvizParams Node nl el cl l
-> [(Node, nl)] -> [(Node, Node, el)] -> DotGraph Node
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 (gr nl el -> [(Node, nl)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
graph) (gr nl el -> [(Node, Node, el)]
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 :: GraphvizParams n nl el cl l
-> [(n, nl)] -> [(n, n, el)] -> DotGraph n
graphElemsToDot params :: GraphvizParams n nl el cl l
params lns :: [(n, nl)]
lns les :: [(n, n, el)]
les
= DotGraph :: forall n.
Bool -> Bool -> Maybe GraphID -> DotStatements n -> DotGraph n
DotGraph { strictGraph :: Bool
strictGraph = Bool
False
, directedGraph :: Bool
directedGraph = Bool
dirGraph
, graphID :: Maybe GraphID
graphID = Maybe GraphID
forall a. Maybe a
Nothing
, graphStatements :: DotStatements n
graphStatements = DotStatements n
stmts
}
where
dirGraph :: Bool
dirGraph = GraphvizParams n nl el cl l -> Bool
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 :: forall n.
[GlobalAttributes]
-> [DotSubGraph n] -> [DotNode n] -> [DotEdge n] -> DotStatements n
DotStmts { attrStmts :: [GlobalAttributes]
attrStmts = GraphvizParams n nl el cl l -> [GlobalAttributes]
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
}
(cs :: [DotSubGraph n]
cs, ns :: [DotNode n]
ns) = ((n, nl) -> NodeCluster cl (n, l))
-> (cl -> Bool)
-> (cl -> GraphID)
-> (cl -> [GlobalAttributes])
-> ((n, l) -> Attributes)
-> [(n, nl)]
-> ([DotSubGraph n], [DotNode n])
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 (GraphvizParams n nl el cl l -> (n, nl) -> NodeCluster cl (n, l)
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) (GraphvizParams n nl el cl l -> cl -> Bool
forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> Bool
isDotCluster GraphvizParams n nl el cl l
params)
(GraphvizParams n nl el cl l -> cl -> GraphID
forall n nl el cl l. GraphvizParams n nl el cl l -> cl -> GraphID
clusterID GraphvizParams n nl el cl l
params) (GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
forall n nl el cl l.
GraphvizParams n nl el cl l -> cl -> [GlobalAttributes]
fmtCluster GraphvizParams n nl el cl l
params) (GraphvizParams n nl el cl l -> (n, l) -> Attributes
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 = ((n, n, el) -> Maybe (DotEdge n)) -> [(n, n, el)] -> [DotEdge n]
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@(f :: n
f,t :: n
t,_) = if Bool
dirGraph Bool -> Bool -> Bool
|| n
f n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
t
then DotEdge n -> Maybe (DotEdge n)
forall a. a -> Maybe a
Just
DotEdge :: forall n. n -> n -> Attributes -> DotEdge n
DotEdge { fromNode :: n
fromNode = n
f
, toNode :: n
toNode = n
t
, edgeAttributes :: Attributes
edgeAttributes = GraphvizParams n nl el cl l -> (n, n, el) -> Attributes
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 Maybe (DotEdge n)
forall a. Maybe a
Nothing
dotToGraph :: (DotRepr dg Node, Graph gr) => dg Node
-> gr Attributes Attributes
dotToGraph :: dg Node -> gr Attributes Attributes
dotToGraph dg :: dg Node
dg = [LNode Attributes]
-> [LEdge Attributes] -> gr Attributes Attributes
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode Attributes]
ns' [LEdge Attributes]
es
where
d :: Bool
d = dg Node -> Bool
forall (dg :: * -> *) n. DotRepr dg n => dg n -> Bool
graphIsDirected dg Node
dg
ns :: [LNode Attributes]
ns = (LNode Attributes -> Node)
-> [LNode Attributes] -> [LNode Attributes]
forall b a. Ord b => (a -> b) -> [a] -> [a]
uniqBy LNode Attributes -> Node
forall a b. (a, b) -> a
fst ([LNode Attributes] -> [LNode Attributes])
-> ([DotNode Node] -> [LNode Attributes])
-> [DotNode Node]
-> [LNode Attributes]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DotNode Node -> LNode Attributes)
-> [DotNode Node] -> [LNode Attributes]
forall a b. (a -> b) -> [a] -> [b]
map DotNode Node -> LNode Attributes
forall a. DotNode a -> (a, Attributes)
toLN ([DotNode Node] -> [LNode Attributes])
-> [DotNode Node] -> [LNode Attributes]
forall a b. (a -> b) -> a -> b
$ dg Node -> [DotNode Node]
forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
es :: [LEdge Attributes]
es = (DotEdge Node -> [LEdge Attributes])
-> [DotEdge Node] -> [LEdge Attributes]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DotEdge Node -> [LEdge Attributes]
forall b. DotEdge b -> [(b, b, Attributes)]
toLE ([DotEdge Node] -> [LEdge Attributes])
-> [DotEdge Node] -> [LEdge Attributes]
forall a b. (a -> b) -> a -> b
$ dg Node -> [DotEdge Node]
forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
nSet :: Set Node
nSet = [Node] -> Set Node
forall a. Ord a => [a] -> Set a
Set.fromList ([Node] -> Set Node) -> [Node] -> Set Node
forall a b. (a -> b) -> a -> b
$ (LNode Attributes -> Node) -> [LNode Attributes] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map LNode Attributes -> Node
forall a b. (a, b) -> a
fst [LNode Attributes]
ns
nEs :: [(Node, [a])]
nEs = (Node -> (Node, [a])) -> [Node] -> [(Node, [a])]
forall a b. (a -> b) -> [a] -> [b]
map ((Node -> [a] -> (Node, [a])) -> [a] -> Node -> (Node, [a])
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) [])
([Node] -> [(Node, [a])])
-> ([Node] -> [Node]) -> [Node] -> [(Node, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node] -> [Node]
forall a. Ord a => [a] -> [a]
uniq
([Node] -> [Node]) -> ([Node] -> [Node]) -> [Node] -> [Node]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter (Node -> Set Node -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Node
nSet)
([Node] -> [(Node, [a])]) -> [Node] -> [(Node, [a])]
forall a b. (a -> b) -> a -> b
$ (LEdge Attributes -> [Node]) -> [LEdge Attributes] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(n1 :: Node
n1,n2 :: Node
n2,_) -> [Node
n1,Node
n2]) [LEdge Attributes]
es
ns' :: [LNode Attributes]
ns' = [LNode Attributes]
ns [LNode Attributes] -> [LNode Attributes] -> [LNode Attributes]
forall a. [a] -> [a] -> [a]
++ [LNode Attributes]
forall a. [(Node, [a])]
nEs
toLN :: DotNode a -> (a, Attributes)
toLN (DotNode n :: a
n as :: Attributes
as) = (a
n,Attributes
as)
toLE :: DotEdge b -> [(b, b, Attributes)]
toLE (DotEdge f :: b
f t :: b
t as :: Attributes
as) = (if Bool
d then [(b, b, Attributes)] -> [(b, b, Attributes)]
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 :: GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
graphToGraph params :: GraphvizParams Node nl el cl l
params gr :: gr nl el
gr = Bool
-> gr nl (EdgeID el)
-> DotGraph Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
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 (GraphvizParams Node nl el cl l -> Bool
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 = GraphvizParams Node nl (EdgeID el) cl l
-> gr nl (EdgeID el) -> DotGraph Node
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 = (LEdge el -> Attributes) -> (Node, Node, EdgeID el) -> Attributes
forall el.
(LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute ((LEdge el -> Attributes) -> (Node, Node, EdgeID el) -> Attributes)
-> (LEdge el -> Attributes)
-> (Node, Node, EdgeID el)
-> Attributes
forall a b. (a -> b) -> a -> b
$ GraphvizParams Node nl el cl l -> LEdge el -> Attributes
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' = gr nl el -> gr nl (EdgeID el)
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 :: GraphvizParams Node nl el cl l
-> gr nl el -> gr (AttributeNode nl) (AttributeEdge el)
dotizeGraph params :: GraphvizParams Node nl el cl l
params gr :: gr nl el
gr = IO (gr (AttributeNode nl) (AttributeEdge el))
-> gr (AttributeNode nl) (AttributeEdge el)
forall a. IO a -> a
unsafePerformIO
(IO (gr (AttributeNode nl) (AttributeEdge el))
-> gr (AttributeNode nl) (AttributeEdge el))
-> IO (gr (AttributeNode nl) (AttributeEdge el))
-> gr (AttributeNode nl) (AttributeEdge el)
forall a b. (a -> b) -> a -> b
$ GraphvizParams Node nl el cl l
-> gr nl el -> IO (gr (AttributeNode nl) (AttributeEdge el))
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
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 = [GlobalAttributes] -> cl -> [GlobalAttributes]
forall a b. a -> b -> a
const []
, fmtNode :: (Node, l) -> Attributes
fmtNode = Attributes -> (Node, l) -> Attributes
forall a b. a -> b -> a
const []
, fmtEdge :: (Node, Node, el) -> Attributes
fmtEdge = Attributes -> (Node, Node, el) -> Attributes
forall a b. a -> b -> a
const []
}
data EdgeID el = EID { EdgeID el -> Text
eID :: Text
, EdgeID el -> el
eLbl :: el
}
deriving (EdgeID el -> EdgeID el -> Bool
(EdgeID el -> EdgeID el -> Bool)
-> (EdgeID el -> EdgeID el -> Bool) -> Eq (EdgeID el)
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, Eq (EdgeID el)
Eq (EdgeID el) =>
(EdgeID el -> EdgeID el -> Ordering)
-> (EdgeID el -> EdgeID el -> Bool)
-> (EdgeID el -> EdgeID el -> Bool)
-> (EdgeID el -> EdgeID el -> Bool)
-> (EdgeID el -> EdgeID el -> Bool)
-> (EdgeID el -> EdgeID el -> EdgeID el)
-> (EdgeID el -> EdgeID el -> EdgeID el)
-> Ord (EdgeID el)
EdgeID el -> EdgeID el -> Bool
EdgeID el -> EdgeID el -> Ordering
EdgeID el -> EdgeID el -> EdgeID el
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
$cp1Ord :: forall el. Ord el => Eq (EdgeID el)
Ord, Node -> EdgeID el -> ShowS
[EdgeID el] -> ShowS
EdgeID el -> [Char]
(Node -> EdgeID el -> ShowS)
-> (EdgeID el -> [Char])
-> ([EdgeID el] -> ShowS)
-> Show (EdgeID el)
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 :: gr nl el -> gr nl (EdgeID el)
addEdgeIDs g :: gr nl el
g = [LNode nl] -> [LEdge (EdgeID el)] -> gr nl (EdgeID el)
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode nl]
ns [LEdge (EdgeID el)]
es'
where
ns :: [LNode nl]
ns = gr nl el -> [LNode nl]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl el
g
es :: [LEdge el]
es = gr nl el -> [LEdge el]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LEdge b]
labEdges gr nl el
g
es' :: [LEdge (EdgeID el)]
es' = (LEdge el -> Node -> LEdge (EdgeID el))
-> [LEdge el] -> [Node] -> [LEdge (EdgeID el)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith LEdge el -> Node -> LEdge (EdgeID el)
forall a a b el. Show a => (a, b, el) -> a -> (a, b, EdgeID el)
addID [LEdge el]
es ([1..] :: [Int])
addID :: (a, b, el) -> a -> (a, b, EdgeID el)
addID (f :: a
f,t :: b
t,l :: el
l) i :: a
i = (a
f,b
t,Text -> el -> EdgeID el
forall el. Text -> el -> EdgeID el
EID ([Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ a -> [Char]
forall a. Show a => a -> [Char]
show a
i) el
l)
setEdgeIDAttribute :: (LEdge el -> Attributes)
-> (LEdge (EdgeID el) -> Attributes)
setEdgeIDAttribute :: (LEdge el -> Attributes) -> LEdge (EdgeID el) -> Attributes
setEdgeIDAttribute f :: LEdge el -> Attributes
f = \ e :: LEdge (EdgeID el)
e@(_,_,eid :: EdgeID el
eid) -> Text -> Attribute
identifierAttribute (EdgeID el -> Text
forall el. EdgeID el -> Text
eID EdgeID el
eid)
Attribute -> Attributes -> Attributes
forall a. a -> [a] -> [a]
: (LEdge el -> Attributes
f (LEdge el -> Attributes)
-> (LEdge (EdgeID el) -> LEdge el)
-> LEdge (EdgeID el)
-> Attributes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LEdge (EdgeID el) -> LEdge el
forall el. LEdge (EdgeID el) -> LEdge el
stripID) LEdge (EdgeID el)
e
identifierAttrName :: AttributeName
identifierAttrName :: Text
identifierAttrName = "graphviz_distinguish_multiple_edges"
identifierAttribute :: Text -> CustomAttribute
identifierAttribute :: Text -> Attribute
identifierAttribute = Text -> Text -> Attribute
customAttribute Text
identifierAttrName
stripID :: LEdge (EdgeID el) -> LEdge el
stripID :: LEdge (EdgeID el) -> LEdge el
stripID (f :: Node
f,t :: Node
t,eid :: EdgeID el
eid) = (Node
f,Node
t, EdgeID el -> el
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 :: Bool
-> gr nl (EdgeID el)
-> dg Node
-> IO (gr (AttributeNode nl) (AttributeEdge el))
dotAttributes isDir :: Bool
isDir gr :: gr nl (EdgeID el)
gr dot :: dg Node
dot
= gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
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 (dg Node -> gr (AttributeNode nl) (AttributeEdge el))
-> (DotGraph Node -> dg Node)
-> DotGraph Node
-> gr (AttributeNode nl) (AttributeEdge el)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotGraph Node -> dg Node
parseDG (DotGraph Node -> gr (AttributeNode nl) (AttributeEdge el))
-> IO (DotGraph Node)
-> IO (gr (AttributeNode nl) (AttributeEdge el))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GraphvizCommand
-> dg Node
-> GraphvizOutput
-> (Handle -> IO (DotGraph Node))
-> IO (DotGraph Node)
forall (dg :: * -> *) n a.
PrintDotRepr dg n =>
GraphvizCommand
-> dg n -> GraphvizOutput -> (Handle -> IO a) -> IO a
graphvizWithHandle GraphvizCommand
command dg Node
dot GraphvizOutput
DotOutput Handle -> IO (DotGraph Node)
forall (dg :: * -> *) n. ParseDotRepr dg n => Handle -> IO (dg n)
hGetDot
where
parseDG :: DotGraph Node -> dg Node
parseDG = (dg Node -> dg Node -> dg Node
forall a. a -> a -> a
`asTypeOf` dg Node
dot) (dg Node -> dg Node)
-> (DotGraph Node -> dg Node) -> DotGraph Node -> dg Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotGraph Node -> dg Node
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 :: gr nl (EdgeID el)
-> dg Node -> gr (AttributeNode nl) (AttributeEdge el)
augmentGraph g :: gr nl (EdgeID el)
g dg :: dg Node
dg = [LNode (AttributeNode nl)]
-> [LEdge (AttributeEdge el)]
-> gr (AttributeNode nl) (AttributeEdge el)
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
mkGraph [LNode (AttributeNode nl)]
lns [LEdge (AttributeEdge el)]
les
where
lns :: [LNode (AttributeNode nl)]
lns = ((Node, nl) -> LNode (AttributeNode nl))
-> [(Node, nl)] -> [LNode (AttributeNode nl)]
forall a b. (a -> b) -> [a] -> [b]
map (\(n :: Node
n, l :: nl
l) -> (Node
n, (Map Node Attributes
nodeMap Map Node Attributes -> Node -> Attributes
forall k a. Ord k => Map k a -> k -> a
Map.! Node
n, nl
l)))
([(Node, nl)] -> [LNode (AttributeNode nl)])
-> [(Node, nl)] -> [LNode (AttributeNode nl)]
forall a b. (a -> b) -> a -> b
$ gr nl (EdgeID el) -> [(Node, nl)]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
labNodes gr nl (EdgeID el)
g
les :: [LEdge (AttributeEdge el)]
les = ((Node, Node, EdgeID el) -> LEdge (AttributeEdge el))
-> [(Node, Node, EdgeID el)] -> [LEdge (AttributeEdge el)]
forall a b. (a -> b) -> [a] -> [b]
map (Node, Node, EdgeID el) -> LEdge (AttributeEdge el)
forall a b b. (a, b, EdgeID b) -> (a, b, (Attributes, b))
augmentEdge ([(Node, Node, EdgeID el)] -> [LEdge (AttributeEdge el)])
-> [(Node, Node, EdgeID el)] -> [LEdge (AttributeEdge el)]
forall a b. (a -> b) -> a -> b
$ gr nl (EdgeID el) -> [(Node, Node, EdgeID el)]
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 (f :: a
f,t :: b
t,EID eid :: Text
eid l :: b
l) = (a
f,b
t, (Map Text Attributes
edgeMap Map Text Attributes -> Text -> Attributes
forall k a. Ord k => Map k a -> k -> a
Map.! Text
eid, b
l))
ns :: [DotNode Node]
ns = dg Node -> [DotNode Node]
forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotNode n]
graphNodes dg Node
dg
es :: [DotEdge Node]
es = dg Node -> [DotEdge Node]
forall (dg :: * -> *) n. DotRepr dg n => dg n -> [DotEdge n]
graphEdges dg Node
dg
nodeMap :: Map Node Attributes
nodeMap = [LNode Attributes] -> Map Node Attributes
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([LNode Attributes] -> Map Node Attributes)
-> [LNode Attributes] -> Map Node Attributes
forall a b. (a -> b) -> a -> b
$ (DotNode Node -> LNode Attributes)
-> [DotNode Node] -> [LNode Attributes]
forall a b. (a -> b) -> [a] -> [b]
map (DotNode Node -> Node
forall n. DotNode n -> n
nodeID (DotNode Node -> Node)
-> (DotNode Node -> Attributes) -> DotNode Node -> LNode Attributes
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& DotNode Node -> Attributes
forall n. DotNode n -> Attributes
nodeAttributes) [DotNode Node]
ns
edgeMap :: Map Text Attributes
edgeMap = [(Text, Attributes)] -> Map Text Attributes
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Attributes)] -> Map Text Attributes)
-> [(Text, Attributes)] -> Map Text Attributes
forall a b. (a -> b) -> a -> b
$ (DotEdge Node -> (Text, Attributes))
-> [DotEdge Node] -> [(Text, Attributes)]
forall a b. (a -> b) -> [a] -> [b]
map DotEdge Node -> (Text, Attributes)
forall n. DotEdge n -> (Text, Attributes)
edgeIDAttrs [DotEdge Node]
es
edgeIDAttrs :: DotEdge n -> (Text, Attributes)
edgeIDAttrs = (Attribute -> Text)
-> (Attribute, Attributes) -> (Text, Attributes)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Attribute -> Text
customValue ((Attribute, Attributes) -> (Text, Attributes))
-> (DotEdge n -> (Attribute, Attributes))
-> DotEdge n
-> (Text, Attributes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Attribute, Attributes) -> (Attribute, Attributes)
forall a. HasCallStack => Maybe a -> a
fromJust
(Maybe (Attribute, Attributes) -> (Attribute, Attributes))
-> (DotEdge n -> Maybe (Attribute, Attributes))
-> DotEdge n
-> (Attribute, Attributes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Attributes -> Maybe (Attribute, Attributes)
findSpecifiedCustom Text
identifierAttrName
(Attributes -> Maybe (Attribute, Attributes))
-> (DotEdge n -> Attributes)
-> DotEdge n
-> Maybe (Attribute, Attributes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DotEdge n -> Attributes
forall n. DotEdge n -> Attributes
edgeAttributes
preview :: (Ord el, Graph gr, Labellable nl, Labellable el) => gr nl el -> IO ()
preview :: gr nl el -> IO ()
preview g :: gr nl el
g = IO ThreadId -> IO ()
forall a. IO a -> IO ()
ign (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ()
forall a. IO a -> IO ()
ign (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DotGraph Node -> GraphvizCanvas -> IO ()
forall (dg :: * -> *) n.
PrintDotRepr dg n =>
dg n -> GraphvizCanvas -> IO ()
runGraphvizCanvas' DotGraph Node
dg GraphvizCanvas
Xlib)
where
dg :: DotGraph Node
dg = (GraphvizParams Node nl el () nl -> gr nl el -> DotGraph Node)
-> GraphvizParams Node nl el () nl -> gr nl el -> DotGraph Node
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 () nl -> gr nl el -> DotGraph Node
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 () nl
forall n. GraphvizParams n nl el () nl
params gr nl el
g
params :: GraphvizParams n nl el () nl
params = GraphvizParams n nl Any () nl
forall n nl el. GraphvizParams n nl el () nl
nonClusteredParams { fmtNode :: (n, nl) -> Attributes
fmtNode = \ (_,l :: nl
l) -> [nl -> Attribute
forall a. Labellable a => a -> Attribute
toLabel nl
l]
, fmtEdge :: (n, n, el) -> Attributes
fmtEdge = \ (_, _, l :: el
l) -> [el -> Attribute
forall a. Labellable a => a -> Attribute
toLabel el
l]
}
ign :: IO a -> IO ()
ign = (IO a -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())