{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.REST.Dot
( mkGraph
, DiGraph(..)
, Edge(..)
, GraphType(..)
, Node(..)
, NodeID
) where
import GHC.Generics
import Data.Hashable
import Data.List
import qualified Data.Set as S
import Text.Printf
import System.Process
data DiGraph = DiGraph
String
(S.Set Node)
(S.Set Edge);
type NodeID = String
data GraphType =
Tree
| Dag
| Min
deriving (ReadPrec [GraphType]
ReadPrec GraphType
Int -> ReadS GraphType
ReadS [GraphType]
(Int -> ReadS GraphType)
-> ReadS [GraphType]
-> ReadPrec GraphType
-> ReadPrec [GraphType]
-> Read GraphType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS GraphType
readsPrec :: Int -> ReadS GraphType
$creadList :: ReadS [GraphType]
readList :: ReadS [GraphType]
$creadPrec :: ReadPrec GraphType
readPrec :: ReadPrec GraphType
$creadListPrec :: ReadPrec [GraphType]
readListPrec :: ReadPrec [GraphType]
Read)
data Node = Node
{ Node -> NodeID
nodeID :: NodeID
, Node -> NodeID
label :: String
, Node -> NodeID
nodeStyle :: String
, Node -> NodeID
labelColor :: String
} deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
/= :: Node -> Node -> Bool
Eq, Eq Node
Eq Node =>
(Node -> Node -> Ordering)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Node)
-> (Node -> Node -> Node)
-> Ord Node
Node -> Node -> Bool
Node -> Node -> Ordering
Node -> Node -> Node
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
$ccompare :: Node -> Node -> Ordering
compare :: Node -> Node -> Ordering
$c< :: Node -> Node -> Bool
< :: Node -> Node -> Bool
$c<= :: Node -> Node -> Bool
<= :: Node -> Node -> Bool
$c> :: Node -> Node -> Bool
> :: Node -> Node -> Bool
$c>= :: Node -> Node -> Bool
>= :: Node -> Node -> Bool
$cmax :: Node -> Node -> Node
max :: Node -> Node -> Node
$cmin :: Node -> Node -> Node
min :: Node -> Node -> Node
Ord, Int -> Node -> NodeID -> NodeID
[Node] -> NodeID -> NodeID
Node -> NodeID
(Int -> Node -> NodeID -> NodeID)
-> (Node -> NodeID) -> ([Node] -> NodeID -> NodeID) -> Show Node
forall a.
(Int -> a -> NodeID -> NodeID)
-> (a -> NodeID) -> ([a] -> NodeID -> NodeID) -> Show a
$cshowsPrec :: Int -> Node -> NodeID -> NodeID
showsPrec :: Int -> Node -> NodeID -> NodeID
$cshow :: Node -> NodeID
show :: Node -> NodeID
$cshowList :: [Node] -> NodeID -> NodeID
showList :: [Node] -> NodeID -> NodeID
Show, (forall x. Node -> Rep Node x)
-> (forall x. Rep Node x -> Node) -> Generic Node
forall x. Rep Node x -> Node
forall x. Node -> Rep Node x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Node -> Rep Node x
from :: forall x. Node -> Rep Node x
$cto :: forall x. Rep Node x -> Node
to :: forall x. Rep Node x -> Node
Generic, Eq Node
Eq Node => (Int -> Node -> Int) -> (Node -> Int) -> Hashable Node
Int -> Node -> Int
Node -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Node -> Int
hashWithSalt :: Int -> Node -> Int
$chash :: Node -> Int
hash :: Node -> Int
Hashable)
data Edge = Edge
{ Edge -> NodeID
from :: NodeID
, Edge -> NodeID
to :: NodeID
, Edge -> NodeID
edgeLabel :: String
, Edge -> NodeID
edgeColor :: String
, Edge -> NodeID
subLabel :: String
, Edge -> NodeID
edgeStyle :: String
} deriving (Edge -> Edge -> Bool
(Edge -> Edge -> Bool) -> (Edge -> Edge -> Bool) -> Eq Edge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
/= :: Edge -> Edge -> Bool
Eq, Eq Edge
Eq Edge =>
(Edge -> Edge -> Ordering)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Bool)
-> (Edge -> Edge -> Edge)
-> (Edge -> Edge -> Edge)
-> Ord Edge
Edge -> Edge -> Bool
Edge -> Edge -> Ordering
Edge -> Edge -> Edge
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
$ccompare :: Edge -> Edge -> Ordering
compare :: Edge -> Edge -> Ordering
$c< :: Edge -> Edge -> Bool
< :: Edge -> Edge -> Bool
$c<= :: Edge -> Edge -> Bool
<= :: Edge -> Edge -> Bool
$c> :: Edge -> Edge -> Bool
> :: Edge -> Edge -> Bool
$c>= :: Edge -> Edge -> Bool
>= :: Edge -> Edge -> Bool
$cmax :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
min :: Edge -> Edge -> Edge
Ord, Int -> Edge -> NodeID -> NodeID
[Edge] -> NodeID -> NodeID
Edge -> NodeID
(Int -> Edge -> NodeID -> NodeID)
-> (Edge -> NodeID) -> ([Edge] -> NodeID -> NodeID) -> Show Edge
forall a.
(Int -> a -> NodeID -> NodeID)
-> (a -> NodeID) -> ([a] -> NodeID -> NodeID) -> Show a
$cshowsPrec :: Int -> Edge -> NodeID -> NodeID
showsPrec :: Int -> Edge -> NodeID -> NodeID
$cshow :: Edge -> NodeID
show :: Edge -> NodeID
$cshowList :: [Edge] -> NodeID -> NodeID
showList :: [Edge] -> NodeID -> NodeID
Show, (forall x. Edge -> Rep Edge x)
-> (forall x. Rep Edge x -> Edge) -> Generic Edge
forall x. Rep Edge x -> Edge
forall x. Edge -> Rep Edge x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Edge -> Rep Edge x
from :: forall x. Edge -> Rep Edge x
$cto :: forall x. Rep Edge x -> Edge
to :: forall x. Rep Edge x -> Edge
Generic, Eq Edge
Eq Edge => (Int -> Edge -> Int) -> (Edge -> Int) -> Hashable Edge
Int -> Edge -> Int
Edge -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> Edge -> Int
hashWithSalt :: Int -> Edge -> Int
$chash :: Edge -> Int
hash :: Edge -> Int
Hashable)
nodeString :: Node -> String
nodeString :: Node -> NodeID
nodeString (Node NodeID
nid NodeID
elabel NodeID
style NodeID
color) =
NodeID -> NodeID -> NodeID -> NodeID -> NodeID -> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"\t%s [label=\"%s\"\nstyle=\"%s\"\ncolor=\"%s\"];" NodeID
nid NodeID
elabel NodeID
style NodeID
color
edgeString :: Edge -> String
edgeString :: Edge -> NodeID
edgeString (Edge NodeID
efrom NodeID
eto NodeID
elabel NodeID
color NodeID
esubLabel NodeID
style) =
let
sub :: NodeID
sub = NodeID -> NodeID
escape NodeID
esubLabel
escape :: NodeID -> NodeID
escape = (Char -> NodeID) -> NodeID -> NodeID
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> NodeID
go
where
go :: Char -> NodeID
go Char
'\\' = NodeID
"\\"
go Char
'\n' = NodeID
"<br />"
go Char
'>' = NodeID
">"
go Char
'<' = NodeID
"<"
go Char
o = [Char
o]
labelPart :: NodeID
labelPart =
if NodeID
elabel NodeID -> NodeID -> Bool
forall a. Eq a => a -> a -> Bool
/= NodeID
""
then NodeID -> NodeID -> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"<font color =\"red\">%s</font>" (NodeID -> NodeID
escape NodeID
elabel)
else NodeID
""
in
NodeID
-> NodeID
-> NodeID
-> NodeID
-> NodeID
-> NodeID
-> NodeID
-> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"\t%s -> %s [label = <%s<br/>%s>\ncolor=\"%s\"\nstyle=\"%s\"];" NodeID
efrom NodeID
eto NodeID
labelPart NodeID
sub NodeID
color NodeID
style
graphString :: DiGraph -> String
graphString :: DiGraph -> NodeID
graphString (DiGraph NodeID
name Set Node
nodes Set Edge
edges) =
NodeID -> NodeID -> NodeID -> NodeID -> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"digraph %s {\n%s\n\n%s\n}" NodeID
name NodeID
nodesString NodeID
edgesString
where
nodesString :: String
nodesString :: NodeID
nodesString = NodeID -> [NodeID] -> NodeID
forall a. [a] -> [[a]] -> [a]
intercalate NodeID
"\n" ((Node -> NodeID) -> [Node] -> [NodeID]
forall a b. (a -> b) -> [a] -> [b]
map Node -> NodeID
nodeString (Set Node -> [Node]
forall a. Set a -> [a]
S.toList Set Node
nodes))
edgesString :: String
edgesString :: NodeID
edgesString = NodeID -> [NodeID] -> NodeID
forall a. [a] -> [[a]] -> [a]
intercalate NodeID
"\n" ((Edge -> NodeID) -> [Edge] -> [NodeID]
forall a b. (a -> b) -> [a] -> [b]
map Edge -> NodeID
edgeString (Set Edge -> [Edge]
forall a. Set a -> [a]
S.toList Set Edge
edges))
mkGraph :: String -> DiGraph -> IO ()
mkGraph :: NodeID -> DiGraph -> IO ()
mkGraph NodeID
name DiGraph
graph = do
let dotfile :: NodeID
dotfile = NodeID -> NodeID -> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"graphs/%s.dot" NodeID
name
let pngfile :: NodeID
pngfile = NodeID -> NodeID -> NodeID
forall r. PrintfType r => NodeID -> r
printf NodeID
"graphs/%s.png" NodeID
name
NodeID -> NodeID -> IO ()
writeFile NodeID
dotfile (DiGraph -> NodeID
graphString DiGraph
graph)
(ExitCode, NodeID, NodeID)
result <- NodeID -> [NodeID] -> NodeID -> IO (ExitCode, NodeID, NodeID)
readProcessWithExitCode NodeID
"dot" [NodeID
"-Tpng", NodeID
dotfile, NodeID
"-o", NodeID
pngfile] NodeID
""
(ExitCode, NodeID, NodeID) -> IO ()
forall a. Show a => a -> IO ()
print (ExitCode, NodeID, NodeID)
result