{-# 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 (Read)
data Node = Node
{ nodeID :: NodeID
, label :: String
, nodeStyle :: String
, labelColor :: String
} deriving (Eq, Ord, Show, Generic, Hashable)
data Edge = Edge
{ from :: NodeID
, to :: NodeID
, edgeLabel :: String
, edgeColor :: String
, subLabel :: String
, edgeStyle :: String
} deriving (Eq, Ord, Show, Generic, Hashable)
type DotPath = [Node]
nodeString :: Node -> String
nodeString (Node id label style color) =
printf "\t%s [label=\"%s\"\nstyle=\"%s\"\ncolor=\"%s\"];" id label style color
edgeString :: Edge -> String
edgeString (Edge from to label color subLabel style) =
let
sub = escape subLabel
escape xs = concatMap go xs
where
go '\\' = "\\"
go '\n' = "
"
go '>' = ">"
go o = [o]
labelPart =
if label /= ""
then printf "%s" label
else ""
in
printf "\t%s -> %s [label = <%s
%s>\ncolor=\"%s\"\nstyle=\"%s\"];" from to labelPart sub color style
graphString :: DiGraph -> String
graphString (DiGraph name nodes edges) =
printf "digraph %s {\n%s\n\n%s\n}" name (nodesString) (edgesString)
where
nodesString :: String
nodesString = intercalate "\n" (map nodeString (S.toList nodes))
edgesString :: String
edgesString = intercalate "\n" (map edgeString (S.toList edges))
mkGraph :: String -> DiGraph -> IO ()
mkGraph name graph = do
let dotfile = printf "graphs/%s.dot" name
let pngfile = printf "graphs/%s.png" name
writeFile dotfile (graphString graph)
result <- readProcessWithExitCode "dot" ["-Tpng", dotfile, "-o", pngfile] ""
print result