{-# 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]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GraphType]
$creadListPrec :: ReadPrec [GraphType]
readPrec :: ReadPrec GraphType
$creadPrec :: ReadPrec GraphType
readList :: ReadS [GraphType]
$creadList :: ReadS [GraphType]
readsPrec :: Int -> ReadS GraphType
$creadsPrec :: Int -> ReadS 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq, Eq 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
min :: Node -> Node -> Node
$cmin :: Node -> Node -> Node
max :: Node -> Node -> Node
$cmax :: Node -> Node -> Node
>= :: Node -> Node -> Bool
$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
compare :: Node -> Node -> Ordering
$ccompare :: Node -> Node -> Ordering
Ord, Int -> Node -> NodeID -> NodeID
[Node] -> NodeID -> NodeID
Node -> NodeID
forall a.
(Int -> a -> NodeID -> NodeID)
-> (a -> NodeID) -> ([a] -> NodeID -> NodeID) -> Show a
showList :: [Node] -> NodeID -> NodeID
$cshowList :: [Node] -> NodeID -> NodeID
show :: Node -> NodeID
$cshow :: Node -> NodeID
showsPrec :: Int -> Node -> NodeID -> NodeID
$cshowsPrec :: Int -> Node -> NodeID -> NodeID
Show, 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
$cto :: forall x. Rep Node x -> Node
$cfrom :: forall x. Node -> Rep Node x
Generic, Eq Node
Int -> Node -> Int
Node -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Node -> Int
$chash :: Node -> Int
hashWithSalt :: Int -> Node -> Int
$chashWithSalt :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c== :: Edge -> Edge -> Bool
Eq, Eq 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
min :: Edge -> Edge -> Edge
$cmin :: Edge -> Edge -> Edge
max :: Edge -> Edge -> Edge
$cmax :: Edge -> Edge -> Edge
>= :: Edge -> Edge -> Bool
$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
compare :: Edge -> Edge -> Ordering
$ccompare :: Edge -> Edge -> Ordering
Ord, Int -> Edge -> NodeID -> NodeID
[Edge] -> NodeID -> NodeID
Edge -> NodeID
forall a.
(Int -> a -> NodeID -> NodeID)
-> (a -> NodeID) -> ([a] -> NodeID -> NodeID) -> Show a
showList :: [Edge] -> NodeID -> NodeID
$cshowList :: [Edge] -> NodeID -> NodeID
show :: Edge -> NodeID
$cshow :: Edge -> NodeID
showsPrec :: Int -> Edge -> NodeID -> NodeID
$cshowsPrec :: Int -> Edge -> NodeID -> NodeID
Show, 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
$cto :: forall x. Rep Edge x -> Edge
$cfrom :: forall x. Edge -> Rep Edge x
Generic, Eq Edge
Int -> Edge -> Int
Edge -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Edge -> Int
$chash :: Edge -> Int
hashWithSalt :: Int -> Edge -> Int
$chashWithSalt :: Int -> Edge -> Int
Hashable)

nodeString :: Node -> String
nodeString :: Node -> NodeID
nodeString (Node NodeID
nid NodeID
elabel NodeID
style NodeID
color) =
    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 = 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 forall a. Eq a => a -> a -> Bool
/= NodeID
""
          then forall r. PrintfType r => NodeID -> r
printf NodeID
"<font color =\"red\">%s</font>" (NodeID -> NodeID
escape NodeID
elabel)
          else NodeID
""
    in
        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) =
    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 = forall a. [a] -> [[a]] -> [a]
intercalate NodeID
"\n" (forall a b. (a -> b) -> [a] -> [b]
map Node -> NodeID
nodeString (forall a. Set a -> [a]
S.toList Set Node
nodes))

        edgesString :: String
        edgesString :: NodeID
edgesString = forall a. [a] -> [[a]] -> [a]
intercalate NodeID
"\n" (forall a b. (a -> b) -> [a] -> [b]
map Edge -> NodeID
edgeString (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 = forall r. PrintfType r => NodeID -> r
printf NodeID
"graphs/%s.dot" NodeID
name
  let pngfile :: NodeID
pngfile = 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
""
  forall a. Show a => a -> IO ()
print (ExitCode, NodeID, NodeID)
result