{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module contains functionality for generating GraphViz graphs
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

-- | A GraphViz directed graph
data DiGraph = DiGraph
  String -- ^ Filename
  (S.Set Node)
  (S.Set Edge);

type NodeID =  String

-- | The way the graph will be rendered
data GraphType =
    Tree -- ^ Standard representation
  | Dag  -- ^ In 'Dag', If two equal terms `n` steps from the root are the same, they are
         --   represented by the same node, even if they were reached via different
         --   paths
  | Min  -- ^ Each unique term is represented by the same node
  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)

-- | A GraphViz node
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)

-- A GraphViz edge
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
"&gt;"
                go Char
'<'  = NodeID
"&lt;"
                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 name graph@ generates the @.dot@ file for @graph@, and renders
--   the resulting graph to a @png@ file using the @dot@ utility
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