module GHC.Vis.Graph (
xDotParse
)
where
import System.IO.Unsafe
import Data.Text.IO
import qualified Data.Text.Lazy as B
import Data.Graph.Inductive hiding (nodes, edges)
import Data.GraphViz hiding (Ellipse, Polygon, parse)
import qualified Data.GraphViz.Types.Generalised as G
import Data.GraphViz.Attributes.Complete
import GHC.HeapView hiding (name)
import GHC.Vis.Internal
import GHC.Vis.Types
import Graphics.XDot.Types hiding (name, h)
import Graphics.XDot.Parser
fontName :: B.Text
fontName = "DejaVu Sans"
graphFontSize :: Double
graphFontSize = 24
nodeFontSize :: Double
nodeFontSize = 24
edgeFontSize :: Double
edgeFontSize = 24
xDotParse :: [(Box, String)] -> IO ([(Maybe Node, Operation)], [Box], Rectangle)
xDotParse as = do
(dotGraph, boxes) <- dg as
return (getOperations dotGraph, boxes, getSize dotGraph)
dg :: [(Box, String)] -> IO (G.DotGraph Node, [Box])
dg as = do
hm <- walkHeap as
xDotText <- graphvizWithHandle Dot (defaultVis $ toViewableGraph $ buildGraph hm) XDot hGetContents
return (parseDotGraph $ B.fromChunks [xDotText], getBoxes hm)
buildGraph :: HeapMap -> Gr Closure String
buildGraph hm = insEdges edges $ insNodes nodes empty
where nodes = zip [0..] $ map (\(_,(_,c)) -> c) rhm
edges = foldr toLEdge [] $ foldr mbEdges [] nodes
rhm = reverse hm
toLEdge (0, Just t) xs = case rhm !! t of
(_,(Just name, _)) -> (0,t,name):xs
(_,(Nothing, _)) -> (0,t,""):xs
toLEdge (f, Just t) xs = (f,t,""):xs
toLEdge _ xs = xs
mbEdges (p,BCOClosure _ _ _ bPtr _ _ _) xs = map (\b -> (p, Just b)) (bcoChildren [bPtr] hm) ++ xs
mbEdges (p,c) xs = map (\b -> (p, boxPos b)) (allPtrs c) ++ xs
boxPos :: Box -> Maybe Int
boxPos b = lookup b $ zip (map fst rhm) [0..]
bcoChildren :: [Box] -> HeapMap -> [Int]
bcoChildren [] _ = []
bcoChildren (b:bs) h = case boxPos b of
Nothing -> let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2
in bcoChildren (ptf ++ bs) h
Just pos -> pos : bcoChildren bs h
getBoxes :: HeapMap -> [Box]
getBoxes hm = map (\(b,(_,_)) -> b) $ reverse hm
toViewableGraph :: Gr Closure String -> Gr String String
toViewableGraph cg = emap id $ nmap showClosure cg
defaultVis :: (Graph gr) => gr String String -> DotGraph Node
defaultVis = graphToDot nonClusteredParams
{ globalAttributes = [GraphAttrs [BgColor [RGBA 0 0 0 0], FontName fontName, FontSize graphFontSize]]
, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize]
, fmtEdge = \ (_,_,l) -> [toLabel l, FontName fontName, FontSize edgeFontSize]
}