module Zora.Graphing.TreeGraphing
( TreeGraphable
, value
, get_children
, is_empty
, graph
) where
import Shelly
import System.Directory (removeFile, getDirectoryContents)
import Control.Exception
import System.IO.Error hiding (catch)
import System.IO.Unsafe
import Data.Maybe
import Data.Tuple
import Data.Monoid
import qualified Data.Map as M
import qualified Data.List as L hiding (zip, map, length, take, drop, takeWhile, last, filter, concatMap)
import qualified Data.Text.Lazy as Ly
import qualified Data.ByteString.Char8 as ByteString
import Data.Graph.Inductive
import Data.GraphViz
import Data.GraphViz.Attributes.Complete hiding (value, Label)
import Data.Word
type Label = Int
class TreeGraphable g where
value :: g a -> a
get_children :: g a -> [g a]
is_empty :: g a -> Bool
zoldMap :: (Monoid m, TreeGraphable g) => (g a -> m) -> g a -> m
zoldMap f node =
if is_empty node
then mempty
else (f node) `mappend` (mconcat . map (zoldMap f) . get_children $ node)
as_graph :: forall a g. (Ord a, Show a, TreeGraphable g) => g a -> ([LNode Ly.Text], [LEdge Ly.Text])
as_graph g = (nodes, edges)
where
nodes :: [LNode Ly.Text]
nodes = zip [0..] $ map show' nodes_in_g
show' :: g a -> Ly.Text
show' = Ly.pack . show . value
nodes_in_g :: [g a]
nodes_in_g = zoldMap (\a -> [a]) g
edges :: [LEdge Ly.Text]
edges = concatMap edgeify nodes_in_g
edgeify :: g a -> [LEdge Ly.Text]
edgeify node =
catMaybes . map maybe_edge . get_children $ node
where
maybe_edge :: g a -> Maybe (LEdge Ly.Text)
maybe_edge child = if is_empty child
then Nothing
else Just
( m M.! (show' node)
, m M.! (show' child)
, Ly.empty )
m :: M.Map Ly.Text Label
m = M.fromList $ map swap nodes
as_dotfile :: forall a g. (Show a, Ord a, TreeGraphable g) => g a -> String
as_dotfile
= Ly.unpack
. printDotGraph
. graphToDot params
. mkGraph'
. as_graph
where
mkGraph' :: ([LNode Ly.Text], [LEdge Ly.Text]) -> (Gr Ly.Text Ly.Text)
mkGraph' (v, e) = mkGraph v e
params :: GraphvizParams n Ly.Text Ly.Text () Ly.Text
params = nonClusteredParams { globalAttributes = ga
, fmtNode = fn
, fmtEdge = fe }
where
fn (_,l) = [textLabel l]
fe (_,_,l) = [textLabel l]
ga = [ GraphAttrs [ RankDir FromTop
, BgColor [toWColor White] ]
, NodeAttrs [ shape BoxShape
, Width 0.1
, Height 0.1 ] ]
graph :: (Show a, Ord a, TreeGraphable g) => g a -> IO String
graph g =
let
outfile :: String
outfile = "graph-" ++ index ++ ".png"
where
index :: String
index
= show
. (+) 1
. (\s -> read s :: Integer)
. takeWhile (/= '.')
. drop 6
. last
$ "graph--1" : graph_files_in_dir
files_in_dir :: IO [String]
files_in_dir = getDirectoryContents "." :: IO [String]
graph_files_in_dir :: [String]
graph_files_in_dir
= L.sort
. filter (starts_with "graph-")
. filter ((==) "graph.png")
. unsafePerformIO
$ files_in_dir
starts_with :: String -> String -> Bool
starts_with prefix str = take (length prefix) str == prefix
run_dot_cmd :: IO ()
run_dot_cmd = shelly $ do
cmd "dot" "-Tpng" "graph.dot" "-ograph.png"
write_dot_file :: IO ()
write_dot_file = do
writeFile "graph.dot" $ as_dotfile g
remove_dot_file :: IO ()
remove_dot_file = removeFile "graph.dot" `catch` handleExists
where
handleExists e
| isDoesNotExistError e = return ()
| otherwise = throwIO e
in
do
write_dot_file
run_dot_cmd
remove_dot_file
return ("Graphed data structure to " ++ "graph.png")