module Zora.Graphing.DAGGraphing
( DAGGraphable
, render
, to_dotfile
, render_dotfile
, expand
) where
import Shelly (shelly, run_, setStdin)
import System.Directory (removeFile, getDirectoryContents)
import Control.Exception
import System.IO.Error hiding (catch)
import Data.Maybe
import Data.String (fromString)
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 as Tx
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 (show_node, Label)
import Data.Word
type Label = Int
class DAGGraphable g where
expand :: g -> Maybe (Maybe String, [(Maybe String, g)])
is_empty :: (DAGGraphable g) => g -> Bool
is_empty = isNothing . expand
show_node :: (DAGGraphable g) => g -> Maybe String
show_node node = if is_empty node
then error "Zora implementation error. We shouldn't be calling this function for an empty node."
else fst . fromJust . expand $ node
get_children :: (DAGGraphable g) => g -> [(Maybe String, g)]
get_children node =
if is_empty node
then error "Zora implementation error. We shouldn't be calling this function for an empty node."
else snd . fromJust . expand $ node
as_graph :: forall g. (Eq g, Show g, DAGGraphable g) => g -> ([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 -> Ly.Text
show' node =
if isNothing . show_node $ node
then Ly.empty
else Ly.pack . fromJust . show_node $ node
nodes_in_g :: [g]
nodes_in_g
= filter (not . is_empty)
. L.nub
. zoldMap (\a -> [a])
$ g
where
zoldMap :: (Monoid m, DAGGraphable g) => (g -> m) -> g -> m
zoldMap f node =
if is_empty node
then mempty
else (f node) `mappend` (mconcat . map (zoldMap f) . map snd . get_children $ node)
edges :: [LEdge Ly.Text]
edges = concatMap edgeify nodes_in_g
edgeify :: g -> [LEdge Ly.Text]
edgeify node
= map make_edge
. filter (not . is_empty . snd)
. get_children
$ node
where
make_edge :: (Maybe String, g) -> LEdge Ly.Text
make_edge (str, child) =
( get_label node
, get_label child
, if isNothing str then Ly.empty else (Ly.pack . fromJust $ str) )
get_label :: g -> Label
get_label node
= snd
. head
. filter ((==) node . fst)
$ zip nodes_in_g [0..]
to_dotfile :: forall g. (Eq g, Show g, DAGGraphable g) => g -> String
to_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 ] ]
render_dotfile :: String -> String -> IO ()
render_dotfile outfile_name dotfile = shelly $ do
setStdin (Tx.pack dotfile)
Shelly.run_ "dot" ["-Tpng", "-o", fromString outfile_name]
render :: (Eq g, Show g, DAGGraphable g) => String -> g -> IO ()
render outfile_name = render_dotfile outfile_name . to_dotfile