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

module Language.REST.Dot 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
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)

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
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: 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
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
$cp1Ord :: Eq Node
Ord, Int -> Node -> ShowS
[Node] -> ShowS
Node -> NodeID
(Int -> Node -> ShowS)
-> (Node -> NodeID) -> ([Node] -> ShowS) -> Show Node
forall a.
(Int -> a -> ShowS) -> (a -> NodeID) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> NodeID
$cshow :: Node -> NodeID
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
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
$cto :: forall x. Rep Node x -> Node
$cfrom :: forall x. Node -> Rep Node x
Generic, Int -> Node -> Int
Node -> Int
(Int -> Node -> Int) -> (Node -> Int) -> Hashable Node
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Node -> Int
$chash :: Node -> Int
hashWithSalt :: Int -> Node -> Int
$chashWithSalt :: Int -> 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
/= :: Edge -> Edge -> Bool
$c/= :: Edge -> Edge -> Bool
== :: Edge -> Edge -> Bool
$c== :: 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
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
$cp1Ord :: Eq Edge
Ord, Int -> Edge -> ShowS
[Edge] -> ShowS
Edge -> NodeID
(Int -> Edge -> ShowS)
-> (Edge -> NodeID) -> ([Edge] -> ShowS) -> Show Edge
forall a.
(Int -> a -> ShowS) -> (a -> NodeID) -> ([a] -> ShowS) -> Show a
showList :: [Edge] -> ShowS
$cshowList :: [Edge] -> ShowS
show :: Edge -> NodeID
$cshow :: Edge -> NodeID
showsPrec :: Int -> Edge -> ShowS
$cshowsPrec :: Int -> Edge -> ShowS
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
$cto :: forall x. Rep Edge x -> Edge
$cfrom :: forall x. Edge -> Rep Edge x
Generic, Int -> Edge -> Int
Edge -> Int
(Int -> Edge -> Int) -> (Edge -> Int) -> Hashable Edge
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Edge -> Int
$chash :: Edge -> Int
hashWithSalt :: Int -> Edge -> Int
$chashWithSalt :: Int -> Edge -> Int
Hashable)

type DotPath = [Node]

nodeString :: Node -> String
nodeString :: Node -> NodeID
nodeString (Node NodeID
nid NodeID
elabel NodeID
style NodeID
color) =
    NodeID -> NodeID -> NodeID -> NodeID -> ShowS
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 = ShowS
forall (t :: * -> *). Foldable t => t Char -> NodeID
escape NodeID
esubLabel
        escape :: t Char -> NodeID
escape t Char
xs = (Char -> NodeID) -> t Char -> NodeID
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> NodeID
go t Char
xs
            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 -> ShowS
forall r. PrintfType r => NodeID -> r
printf NodeID
"<font color =\"red\">%s</font>" (ShowS
forall (t :: * -> *). Foldable t => t Char -> NodeID
escape NodeID
elabel)
          else NodeID
""
    in
        NodeID -> NodeID -> NodeID -> NodeID -> NodeID -> NodeID -> ShowS
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 -> ShowS
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 -> ShowS
forall r. PrintfType r => NodeID -> r
printf NodeID
"graphs/%s.dot" NodeID
name
  let pngfile :: NodeID
pngfile = NodeID -> ShowS
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