{-# 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 ">" 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 -> 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