ghc-vis 0.2.1 → 0.3
raw patch · 12 files changed
+920/−758 lines, 12 filesdep +transformersdep ~basedep ~cairodep ~graphviz
Dependencies added: transformers
Dependency ranges changed: base, cairo, graphviz, gtk, mtl, xdot
Files
- ghc-vis.cabal +20/−10
- src/GHC/Vis.hs +42/−18
- src/GHC/Vis/GTK/Common.hs +0/−68
- src/GHC/Vis/GTK/Graph.hs +0/−157
- src/GHC/Vis/GTK/List.hs +0/−324
- src/GHC/Vis/Graph.hs +0/−113
- src/GHC/Vis/Internal.hs +108/−65
- src/GHC/Vis/Types.hs +16/−3
- src/GHC/Vis/View/Common.hs +65/−0
- src/GHC/Vis/View/Graph.hs +164/−0
- src/GHC/Vis/View/Graph/Parser.hs +129/−0
- src/GHC/Vis/View/List.hs +376/−0
ghc-vis.cabal view
@@ -1,5 +1,5 @@ name: ghc-vis-version: 0.2.1+version: 0.3 license: BSD3 license-file: LICENSE category: GHC, Debug, Development@@ -18,7 +18,7 @@ To use this package add the accompanying @ghci@ file to your @.ghci@ like this: .- > echo ":script $HOME/.cabal/share/ghc-vis-0.2.1/ghci" >> ~/.ghci+ > echo ":script $HOME/.cabal/share/ghc-vis-0.3/ghci" >> ~/.ghci . Now you can run ghci and experiment with @ghc-vis@. Start the visualization:@@ -78,21 +78,31 @@ data-files: ghci Extra-source-files: nonghci-test.hs +flag graph+ Default: True+ Description: "Enable graph view using Graphviz"+ Library- Exposed-modules: GHC.Vis GHC.Vis.Internal GHC.Vis.Graph GHC.Vis.Types GHC.Vis.GTK.Graph GHC.Vis.GTK.List GHC.Vis.GTK.Common+ Exposed-modules: GHC.Vis+ Other-modules: GHC.Vis.Internal GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common Default-Language: Haskell2010- Build-depends: base == 4.5.*,+ Build-depends: base == 4.*,+ mtl >= 2.0, fgl,- mtl, deepseq,- ghc-heap-view >= 0.3,- cairo,- gtk,- graphviz, text,- xdot+ transformers,+ gtk == 0.12.*,+ cairo == 0.12.*,+ ghc-heap-view >= 0.3 Hs-source-dirs: src/ Ghc-options: -Wall -fno-warn-unused-do-bind++ if flag(graph)+ Other-modules: GHC.Vis.View.Graph.Parser GHC.Vis.View.Graph+ Build-depends: graphviz >= 2999.14.1.0,+ xdot >= 0.2+ Cpp-options: -DGRAPH_VIEW --source-repository head -- type: darcs
src/GHC/Vis.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {- | Module : GHC.Vis Copyright : (c) Dennis Felsing@@ -63,10 +64,22 @@ import GHC.Vis.Types hiding (view) import qualified GHC.Vis.Types as T-import GHC.Vis.GTK.Common-import qualified GHC.Vis.GTK.Graph as Graph-import qualified GHC.Vis.GTK.List as List+import GHC.Vis.View.Common+import qualified GHC.Vis.View.List as List +#ifdef GRAPH_VIEW+import Data.GraphViz.Commands+import qualified GHC.Vis.View.Graph as Graph+#endif++views :: [View]+views =+ View List.redraw List.click List.move List.updateObjects List.export :+#ifdef GRAPH_VIEW+ View Graph.redraw Graph.click Graph.move Graph.updateObjects Graph.export :+#endif+ []+ title :: String title = "ghc-vis" @@ -113,7 +126,7 @@ export filename = put $ ExportSignal filename put :: Signal -> IO ()-put s = (timeout signalTimeout $ putMVar visSignal s) >> return ()+put s = void $ timeout signalTimeout $ putMVar visSignal s visMainThread :: IO () visMainThread = do@@ -130,18 +143,18 @@ (uncurry $ windowSetDefaultSize window) defaultSize onExpose canvas $ const $ do- runCorrect Graph.redraw List.redraw >>= \f -> f canvas- runCorrect Graph.move List.move >>= \f -> f canvas+ runCorrect redraw >>= \f -> f canvas+ runCorrect move >>= \f -> f canvas return True onMotionNotify canvas False $ \e -> do modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)})- runCorrect Graph.move List.move >>= \f -> f canvas+ runCorrect move >>= \f -> f canvas return True onButtonPress canvas $ \e -> do- click <- runCorrect Graph.click List.click- when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) click+ cf <- runCorrect click+ when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) cf return True widgetShowAll window@@ -179,25 +192,36 @@ \y -> if (x,n) `elem` y then return y else return $ y ++ [(x,n)]) ClearSignal -> modifyMVar_ visBoxes (\_ -> return []) UpdateSignal -> return ()- SwitchSignal -> modifyIORef visState (\s -> s {T.view = succN (T.view s)})- ExportSignal f -> catch (runCorrect Graph.export List.export >>= \e -> e f)+ SwitchSignal -> doSwitch+ ExportSignal f -> catch (runCorrect exportView >>= \e -> e f) (\e -> do let err = show (e :: IOException) hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err return ()) boxes <- readMVar visBoxes performGC -- TODO: Else Blackholes appear. Do we want this?+ -- Example for bad behaviour that would happen then:+ -- λ> let xs = [1..42] :: [Int]+ -- λ> let x = 17 :: Int+ -- λ> let ys = [ y | y <- xs, y >= x ] - runCorrect Graph.updateObjects List.updateObjects >>= \f -> f boxes+ runCorrect updateObjects >>= \f -> f boxes postGUISync $ widgetQueueDraw canvas react canvas window - where succN v = if v == maxBound then minBound else succ v+#ifdef GRAPH_VIEW+ where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi+ then modifyIORef visState (\s -> s {T.view = succN (T.view s)})+ else putStrLn "Cannot switch view: Graphviz not installed" -runCorrect :: f -> f -> IO f-runCorrect f1 f2 = do+ succN GraphView = ListView+ succN ListView = GraphView+#else+ where doSwitch = putStrLn "Cannot switch view: Graph view disabled at build"+#endif++runCorrect :: (View -> f) -> IO f+runCorrect f = do s <- readIORef visState- return $ case T.view s of- GraphView -> f1- ListView -> f2+ return $ f $ views !! fromEnum (T.view s)
− src/GHC/Vis/GTK/Common.hs
@@ -1,68 +0,0 @@-{- |- Module : GHC.Vis.GTK.Common- Copyright : (c) Dennis Felsing- License : 3-Clause BSD-style- Maintainer : dennis@felsin9.de-- -}-module GHC.Vis.GTK.Common (- visSignal,- visRunning,- visState,- visBoxes,- evaluate,- --printOne,- --printAll- )- where--import Control.Concurrent-import Control.DeepSeq--import Data.IORef--import System.IO.Unsafe--import GHC.Vis.Internal-import GHC.Vis.Types-import GHC.HeapView---- | Communication channel to the visualization-visSignal :: MVar Signal-visSignal = unsafePerformIO (newEmptyMVar :: IO (MVar Signal))---- | Whether a visualization is currently running-visRunning :: MVar Bool-visRunning = unsafePerformIO (newMVar False)---- | Internal state of the visualization-visState :: IORef State-visState = unsafePerformIO $ newIORef $ State (0, 0) ListView---- | All the visualized boxes-visBoxes :: MVar [(Box, String)]-visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [(Box, String)]))---- | Evaluate an object identified by a String.-evaluate :: String -> IO ()-evaluate identifier = do (_,hm) <- printAll- show (map go hm) `deepseq` return ()- where go (Box a,(Just n, y)) | n == identifier = seq a (Just n, y)- | otherwise = (Just n, y)- go (_,(x,y)) = (x,y)----printOne :: a -> IO String---printOne a = do--- bs <- readMVar visBoxes--- case findIndex (\(b,_) -> asBox a == b) bs of--- Just pos -> do--- t <- parseBoxes bs--- return $ show (t !! pos)--- Nothing -> return "Add entry first"--printAll :: IO (String, HeapMap)-printAll = do- bs <- readMVar visBoxes- (t,(_,h,_)) <- parseBoxesHeap bs- return (show t, h)-
− src/GHC/Vis/GTK/Graph.hs
@@ -1,157 +0,0 @@-{- |- Module : GHC.Vis.GTK.Graph- Copyright : (c) Dennis Felsing- License : 3-Clause BSD-style- Maintainer : dennis@felsin9.de-- -}-module GHC.Vis.GTK.Graph (- export,- redraw,- click,- move,- updateObjects- )- where--import Graphics.UI.Gtk hiding (Box, Signal, Rectangle)-import qualified Graphics.UI.Gtk as Gtk-import Graphics.Rendering.Cairo--import Control.Concurrent-import Control.Monad--import Data.IORef-import System.IO.Unsafe--import GHC.Vis.Graph-import GHC.Vis.Types hiding (State)-import GHC.Vis.GTK.Common--import GHC.HeapView hiding (size)--import Graphics.XDot.Viewer-import Graphics.XDot.Types hiding (size, w, h)--data State = State- { boxes :: [Box]- , operations :: [(Maybe Int, Operation)]- , totalSize :: (Double, Double, Double, Double)- , bounds :: [(Int, (Double, Double, Double, Double))]- , hover :: Maybe Int- }--state :: IORef State-state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] Nothing---- | Draw visualization to screen, called on every update or when it's--- requested from outside the program.-redraw :: WidgetClass w => w -> IO ()-redraw canvas = do- s <- readIORef state- Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas-- boundingBoxes <- render canvas (draw s rw2 rh2)-- modifyIORef state (\s' -> s' {bounds = boundingBoxes})---- | Export the visualization to an SVG file-export :: String -> IO ()-export file = do- s <- readIORef state-- let (_, _, xSize, ySize) = totalSize s-- withSVGSurface file xSize ySize- (\surface -> renderWith surface (draw s (round xSize) (round ySize)))-- return ()--draw :: State -> Int -> Int -> Render [(Int, Rectangle)]-draw s rw2 rh2 = do- -- Line widths don't count to size, let's add a bit- let rw = 0.97 * fromIntegral rw2- rh = 0.97 * fromIntegral rh2-- ops = operations s- size@(_,_,sw,sh) = totalSize s-- -- Proportional scaling- sx = min (rw / sw) (rh / sh)- sy = sx- ox = 0.5 * fromIntegral rw2- oy = 0.5 * fromIntegral rh2-- translate ox oy- scale sx sy-- result <- drawAll (hover s) size ops-- return $ map (\(o, (x,y,w,h)) -> (o,- ( x * sx + ox -- Transformations to correct scaling and offset- , y * sy + oy- , w * sx- , h * sy- ))) result--render :: WidgetClass w => w -> Render b -> IO b-render canvas r = do- win <- widgetGetDrawWindow canvas- renderWithDrawable win r---- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent--- that causes the object to be evaluated and the screen to be updated.-click :: IO ()-click = do- s <- readIORef state-- case hover s of- Just t -> do- evaluate2 $ boxes s !! t- putMVar visSignal UpdateSignal- _ -> return ()--evaluate2 :: Box -> IO ()-evaluate2 b@(Box a) = do- c <- getBoxedClosureData b- case c of- -- ghc: internal error: MUT_ARR_PTRS_FROZEN object entered!- -- (GHC version 7.4.2 for x86_64_unknown_linux)- -- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug- --ArrWordsClosure _ _ _ -> return () -- Don't inspect ArrWords- --MutArrClosure _ _ _ _ -> return ()- --MVarClosure _ _ _ _ -> return ()- --_ -> a `seq` return ()- IndClosure{} -> a `seq` return ()- BlackholeClosure{} -> a `seq` return ()- FunClosure{} -> a `seq` return ()- ThunkClosure{} -> a `seq` return ()- APClosure{} -> a `seq` return ()- PAPClosure{} -> a `seq` return ()- _ -> return ()---- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a--- different object now, so the object gets highlighted and the screen--- updated.-move :: WidgetClass w => w -> IO ()-move canvas = do- vs <- readIORef visState- oldS <- readIORef state- let oldHover = hover oldS-- modifyIORef state $ \s' -> (- let (mx, my) = mousePos vs- check (o, (x,y,w,h)) =- if x <= mx && mx <= x + w &&- y <= my && my <= y + h- then Just o else Nothing- in s' {hover = msum $ map check (bounds oldS)}- )- s <- readIORef state- unless (oldHover == hover s) $ widgetQueueDraw canvas---- | Something might have changed on the heap, update the view.-updateObjects :: [(Box, String)] -> IO ()-updateObjects bs = do- (ops, bs', size) <- xDotParse bs- modifyIORef state (\s -> s {operations = ops, boxes = bs', totalSize = size})
− src/GHC/Vis/GTK/List.hs
@@ -1,324 +0,0 @@-{- |- Module : GHC.Vis.GTK.List- Copyright : (c) Dennis Felsing- License : 3-Clause BSD-style- Maintainer : dennis@felsin9.de-- -}-module GHC.Vis.GTK.List (- export,- redraw,- click,- move,- updateObjects- )- where-import Graphics.UI.Gtk hiding (Box, Signal, Rectangle)-import qualified Graphics.UI.Gtk as Gtk-import Graphics.Rendering.Cairo--import Control.Concurrent-import Control.Monad--import Data.IORef-import System.IO.Unsafe--import GHC.Vis.Internal-import GHC.Vis.Types hiding (State)-import GHC.Vis.GTK.Common--import GHC.HeapView (Box)--type Rectangle = (Double, Double, Double, Double)--data State = State- { objects :: [[VisObject]]- , bounds :: [(String, Rectangle)]- , hover :: Maybe String- }--type RGB = (Double, Double, Double)--state :: IORef State-state = unsafePerformIO $ newIORef $ State [] [] Nothing--fontName :: String--- Cairo's internal font system doesn't detect this as a similar font to "Times--- Roman", should switch to Pango---fontName = "Nimbus Roman No9 L"-fontName = "DejaVu Sans"--fontSize :: Double-fontSize = 15--colorName :: RGB-colorName = (0.5,1,0.5)--colorNameHighlighted :: RGB-colorNameHighlighted = (0,1,0)--colorLink :: RGB-colorLink = (0.5,0.5,1)--colorLinkHighlighted :: RGB-colorLinkHighlighted = (0.25,0.25,1)--colorFunction :: RGB-colorFunction = (1,0.5,0.5)--colorFunctionHighlighted :: RGB-colorFunctionHighlighted = (1,0,0)--padding :: Double-padding = 5---- | Draw visualization to screen, called on every update or when it's--- requested from outside the program.-redraw :: WidgetClass w => w -> IO ()-redraw canvas = do- boxes <- readMVar visBoxes- s <- readIORef state- Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas-- boundingBoxes <- render canvas (draw s rw2 rh2 boxes)- modifyIORef state (\s' -> s' {bounds = boundingBoxes})---- | Export the visualization to an SVG file-export :: String -> IO ()-export file = do- boxes <- readMVar visBoxes- s <- readIORef state-- withSVGSurface file (fromIntegral xSize) (fromIntegral ySize)- (\surface -> renderWith surface (draw s xSize ySize boxes))-- return ()-- where xSize = 500 :: Int- ySize = 500 :: Int--draw :: State -> Int -> Int -> [(a, String)] -> Render [(String, Rectangle)]-draw s rw2 rh2 boxes = do- let objs = objects s- names = map ((++ ": ") . snd) boxes-- nameWidths <- mapM (width . Unnamed) names- pos <- mapM height objs- widths <- mapM (mapM width) objs-- -- Text sizes aren't always perfect, assume that texts may be a bit too big- let rw = 0.97 * fromIntegral rw2- rh = 0.99 * fromIntegral rh2-- maxNameWidth = maximum nameWidths- widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths-- sw = maximum widths2- sh = sum (map (+ 30) pos) - 15-- sx = min (rw / sw) (rh / sh)- sy = sx- ox = 0- oy = 0-- translate ox oy- scale sx sy-- let rpos = scanl (\a b -> a + b + 30) 30 pos- result <- mapM (drawEntry s maxNameWidth) (zip3 objs rpos names)-- return $ map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result--render :: WidgetClass w => w -> Render b -> IO b-render canvas r = do- win <- widgetGetDrawWindow canvas- renderWithDrawable win $ do- selectFontFace fontName FontSlantNormal FontWeightNormal- setFontSize fontSize- r---- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent--- that causes the object to be evaluated and the screen to be updated.-click :: IO ()-click = do- s <- readIORef state-- case hover s of- Just t -> do- evaluate t- putMVar visSignal UpdateSignal- _ -> return ()---- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a--- different object now, so the object gets highlighted and the screen--- updated.-move :: WidgetClass w => w -> IO ()-move canvas = do- vS <- readIORef visState- oldS <- readIORef state- let oldHover = hover oldS-- modifyIORef state $ \s' -> (- let (mx, my) = mousePos vS- check (o, (x,y,w,h)) =- if x <= mx && mx <= x + w &&- y <= my && my <= y + h- then Just o else Nothing- in s' {hover = msum $ map check (bounds s')}- )- s <- readIORef state- unless (oldHover == hover s) $ widgetQueueDraw canvas---- | Something might have changed on the heap, update the view.-updateObjects :: [(Box, String)] -> IO ()-updateObjects boxes = do- objs <- parseBoxes boxes- modifyIORef state (\s -> s {objects = objs})--drawEntry :: State -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]-drawEntry s nameWidth (obj, pos, name) = do- save- translate 0 pos- moveTo 0 0- drawBox s $ Unnamed name- --setSourceRGB 0 0 0- --showText name- translate nameWidth 0- moveTo 0 0- boundingBoxes <- mapM (drawBox s) obj- restore- return $ map (\(o, (x,y,w,h)) -> (o, (x+nameWidth,y+pos,w,h))) $ concat boundingBoxes--drawBox :: State -> VisObject -> Render [(String, Rectangle)]-drawBox _ o@(Unnamed content) = do- (x,_) <- getCurrentPoint- wc <- width o- moveTo (x + padding/2) 0- setSourceRGB 0 0 0- showText content- --translate wc 0- moveTo (x + wc) 0-- return []--drawBox s o@(Function target) =- drawFunctionLink s o target colorFunction colorFunctionHighlighted--drawBox s o@(Link target) =- drawFunctionLink s o target colorLink colorLinkHighlighted--drawBox s o@(Named name content) = do- (x,_) <- getCurrentPoint- TextExtents xb _ _ _ xa _ <- textExtents name- FontExtents fa _ fh _ _ <- fontExtents- hc <- height content- wc <- width o-- let (ux, uy, uw, uh) =- ( x- , -fa - padding- , wc- , fh + 10 + hc- )-- setLineCap LineCapRound- roundedRect ux uy uw uh-- setColor s name colorName colorNameHighlighted-- fillAndSurround-- moveTo ux (hc + 5 - fa - padding)- lineTo (ux + uw) (hc + 5 - fa - padding)- stroke-- save- moveTo (x + padding) 0- bb <- mapM (drawBox s) content- restore-- moveTo (x + uw/2 - (xa - xb)/2) (hc + 7.5 - padding)- showText name- moveTo (x + wc) 0-- return $ concat bb ++ [(name, (ux, uy, uw, uh))]--drawFunctionLink :: State -> VisObject -> String -> RGB -> RGB -> Render [(String, Rectangle)]-drawFunctionLink s o target color1 color2 = do- (x,_) <- getCurrentPoint- FontExtents fa _ fh _ _ <- fontExtents- wc <- width o-- let (ux, uy, uw, uh) =- ( x- , (-fa) - padding- , wc- , fh + 10- )-- setLineCap LineCapRound- roundedRect ux uy uw uh-- setColor s target color1 color2-- fillAndSurround-- moveTo (x + padding) 0- showText target- moveTo (x + wc) 0-- return [(target, (ux, uy, uw, uh))]--setColor :: State -> String -> RGB -> RGB -> Render ()-setColor s name (r,g,b) (r',g',b') = case hover s of- Just t -> if t == name then setSourceRGB r' g' b'- else setSourceRGB r g b- _ -> setSourceRGB r g b--fillAndSurround :: Render ()-fillAndSurround = do- fillPreserve- setSourceRGB 0 0 0- stroke--roundedRect :: Double -> Double -> Double -> Double -> Render ()-roundedRect x y w h = do- moveTo x (y + pad)- lineTo x (y + h - pad)- arcNegative (x + pad) (y + h - pad) pad pi (pi/2)- lineTo (x + w - pad) (y + h)- arcNegative (x + w - pad) (y + h - pad) pad (pi/2) 0- lineTo (x + w) (y + pad)- arcNegative (x + w - pad) (y + pad) pad 0 (-pi/2)- lineTo (x + pad) y- arcNegative (x + pad) (y + pad) pad (-pi/2) (-pi)- closePath-- where pad = 1/10 * min w h--height :: [VisObject] -> Render Double-height xs = do- FontExtents _ _ fh _ _ <- fontExtents- let go (Named _ ys) = (fh + 15) + maximum (map go ys)- go (Unnamed _) = fh- go (Link _) = fh + 10- go (Function _) = fh + 10- return $ maximum $ map go xs--width :: VisObject -> Render Double-width (Named x ys) = do- TextExtents xb _ _ _ xa _ <- textExtents x- w2s <- mapM width ys- return $ max (xa - xb) (sum w2s) + 10--width (Unnamed x) = do- TextExtents xb _ _ _ xa _ <- textExtents x- return $ xa - xb + 5--width (Link x) = do- TextExtents xb _ _ _ xa _ <- textExtents x- return $ xa - xb + 10--width (Function x) = do- TextExtents xb _ _ _ xa _ <- textExtents x- return $ xa - xb + 10
− src/GHC/Vis/Graph.hs
@@ -1,113 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--{- |- Module : GHC.Vis.Graph- Copyright : (c) Dennis Felsing- License : 3-Clause BSD-style- Maintainer : dennis@felsin9.de-- -}-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 = "Times Roman"-fontName = "DejaVu Sans"--graphFontSize :: Double-graphFontSize = 24--nodeFontSize :: Double-nodeFontSize = 24--edgeFontSize :: Double-edgeFontSize = 24---- | Take the objects to be visualized and run them through @dot@ and extract--- the drawing operations that have to be exectued to show the graph of the--- heap map.-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- --hm <- walkHeapDepth as- xDotText <- graphvizWithHandle Dot (defaultVis $ toViewableGraph $ buildGraph hm) XDot hGetContents- return (parseDotGraph $ B.fromChunks [xDotText], getBoxes hm)---- | Convert a heap map, our internal data structure, to a graph that can be--- converted to a dot graph.-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- -- Reversing it fixes the ordering of nodes in the graph. Should run- -- through allPtrs and sort by order inside of all allPtrs lists.- --- -- When building the graph directly out of [Box] instead of going- -- through the HeapMap, then the order of nodes might not be right for- -- non-trivial graphs.- --- -- In some cases it's impossible to get the order right. Maybe there is- -- a way in graphviz to specify outgoing edge orientation after all?- 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- -- Using allPtrs and then filtering the closures not available in the- -- heap map out emulates pointersToFollow without being in IO- 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 -- Could go into infinite loop- Just pos -> pos : bcoChildren bs h--getBoxes :: HeapMap -> [Box]-getBoxes hm = map (\(b,(_,_)) -> b) $ reverse hm---- Probably have to do some kind of fold over the graph to remove for example--- unwanted pointers-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- -- Somehow (X11Color Transparency) is white, use (RGBA 0 0 0 0) instead- { 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]- }
src/GHC/Vis/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MagicHash, DeriveDataTypeable, NoMonomorphismRestriction, RankNTypes #-} {- | Module : GHC.Vis.Internal@@ -9,52 +9,69 @@ -} module GHC.Vis.Internal ( walkHeap,- --walkHeapDepth, parseBoxes, parseBoxesHeap,- --parseClosure,- --pointersToFollow, pointersToFollow2, showClosure ) where +import Prelude hiding (catch)+ import GHC.Vis.Types import GHC.HeapView hiding (name, pkg, modl, fun, arrWords) import Control.Monad import Control.Monad.State hiding (State, fix)+ import Data.Word import Data.Char import Data.List hiding (insert)+ import Text.Printf import Unsafe.Coerce +import Control.Monad.Trans.Maybe+ import System.IO.Unsafe -- | Walk the heap for a list of objects to be visualized and their -- corresponding names. parseBoxes :: [(Box, String)] -> IO [[VisObject]]-parseBoxes = generalParseBoxes evalState+parseBoxes bs = do+ r <- generalParseBoxes evalState bs+ case r of+ Just x -> return x+ _ -> parseBoxes bs -- | Walk the heap for a list of objects to be visualized and their -- corresponding names. Also return the resulting 'HeapMap' and another -- 'HeapMap' that does not contain BCO pointers. parseBoxesHeap :: [(Box, String)] -> IO ([[VisObject]], (Integer, HeapMap, HeapMap))-parseBoxesHeap = generalParseBoxes runState+parseBoxesHeap bs = do+ r <- generalParseBoxes runState bs+ case r of+ (Just x, y) -> return (x,y)+ _ -> parseBoxesHeap bs generalParseBoxes :: Num t =>- (PrintState [[VisObject]] -> (t, HeapMap, HeapMap) -> b)+ (PrintState (Maybe [[VisObject]]) -> (t, HeapMap, HeapMap) -> b) -> [(Box, String)] -> IO b-generalParseBoxes f bs = walkHeapSimply bs >>= \h -> walkHeapWithBCO bs >>= \h2 -> return $ f (go bs) (0,h,h2)- where go ((b',_):b's) = do (_,h,_) <- get- let (Just (_,c)) = lookup b' h+generalParseBoxes f bs = do+ h <- walkHeapSimply bs+ h2 <- walkHeapWithBCO bs+ return $ f (g bs) (0,h,h2)+ where g bs' = runMaybeT $ go bs'+ go ((b',_):b's) = do (_,h,_) <- lift get+ (_,c) <- lookupT b' h r <- parseClosure b' c rs <- go b's- --return (r:rs)- return (simplify r:rs)+ return $ simplify r : rs go [] = return [] +lookupT :: Eq a => a -> [(a,b)] -> MaybeT PrintState b+lookupT b' h = MaybeT $ return $ lookup b' h+ -- Pulls together multiple Unnamed objects to one simplify :: [VisObject] -> [VisObject] simplify [] = []@@ -64,7 +81,7 @@ simplify (Named a bs : xs) = Named a (simplify bs) : simplify xs simplify (a:xs) = a : simplify xs -parseClosure :: Box -> Closure -> PrintState [VisObject]+parseClosure :: Box -> Closure -> MaybeT PrintState [VisObject] parseClosure b c = do o <- correctObject b case o of@@ -72,20 +89,17 @@ _ -> do i <- parseInternal b c return $ insertObjects o i -fromJust1 :: String -> Maybe t -> t-fromJust1 _ (Just n) = n-fromJust1 x _ = error $ "Invalid fromJust " ++ x--correctObject :: Box -> PrintState VisObject+correctObject :: Box -> MaybeT PrintState VisObject correctObject box = do- r <- countReferences box+ r <- lift $ countReferences box n <- getName box case n of Just name -> return $ Link name Nothing -> if r > 1 then (do setName box- name <- liftM (fromJust1 "1") $ getName box+ mbName <- getName box+ name <- MaybeT $ return mbName return $ Named name []) else return $ Unnamed "" @@ -183,27 +197,29 @@ Just _ -> xs Nothing -> (b,x):xs -adjust :: (HeapEntry -> HeapEntry) -> Box -> HeapMap -> HeapMap-adjust f b h = h1 ++ ((b,f x) : h2)- where i = fromJust1 "2" $ findIndex (\(y,_) -> y == b) h- (h1,(_,x):h2) = splitAt i h+adjust :: (HeapEntry -> HeapEntry) -> Box -> HeapMap -> Maybe HeapMap+adjust f b h = do i <- findIndex (\(y,_) -> y == b) h+ let (h1,(_,x):h2) = splitAt i h+ return $ h1 ++ ((b,f x) : h2) -setName :: Box -> PrintState ()-setName b = modify go- where go (i,h,h2) = (i + 1, adjust (set i) b h, h2)- set i (Nothing, closure) = (Just ('t' : show i), closure)+setName :: Box -> MaybeT PrintState ()+setName b = do (i, h, h2) <- lift get+ h' <- MaybeT $ return $ adjust (set i) b h+ lift $ put (i + 1, h', h2)+ where set i (Nothing, closure) = (Just ('t' : show i), closure) set _ _ = error "unexpected pattern" -getName :: Box -> PrintState (Maybe String)-getName b = do (_,h,_) <- get- return $ fst $ fromJust1 "3" $ lookup b h+getName :: Box -> MaybeT PrintState (Maybe String)+getName b = do (_,h,_) <- lift get+ (name,_) <- lookupT b h+ return name -getSetName :: Box -> PrintState String+getSetName :: Box -> MaybeT PrintState String getSetName b = do mn <- getName b case mn of Nothing -> do setName b- n <- getName b- return $ fromJust1 "4" n+ name <- getName b+ MaybeT $ return name Just name -> return name -- How often is a box referenced in the entire heap map@@ -213,7 +229,7 @@ return $ sum $ map countR h where countR (_,(_,c)) = length $ filter (== b) $ allPtrs c -parseInternal :: Box -> Closure -> PrintState [VisObject]+parseInternal :: Box -> Closure -> MaybeT PrintState [VisObject] parseInternal _ (ConsClosure StgInfoTable{} _ [dataArg] _pkg modl name) = return [Unnamed $ case (modl, name) of k | k `elem` [ ("GHC.Word", "W#")@@ -273,7 +289,7 @@ let tPtrs = intercalate [Unnamed " "] cPtrs return $ Unnamed (name ++ " ") : tPtrs -parseInternal _ (ConsClosure (StgInfoTable _ _ _ _) bPtrs dArgs _ _ name)+parseInternal _ (ConsClosure StgInfoTable{} bPtrs dArgs _ _ name) = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs let tPtrs = intercalate [Unnamed " "] cPtrs return $ Unnamed (name ++ show dArgs ++ " ") : tPtrs@@ -284,6 +300,9 @@ parseInternal _ (IndClosure (StgInfoTable 1 0 _ 0) b) = contParse b +parseInternal _ (SelectorClosure StgInfoTable{} b)+ = contParse b+ parseInternal _ (BlackholeClosure (StgInfoTable 1 0 _ 0) b) = contParse b @@ -320,12 +339,11 @@ -- notHasName _ _ = True -- return vs -parseInternal b (APClosure (StgInfoTable 0 0 _ _) _ _ fun _)- = do cPtr <- contParse fun- getSetName b >>= \x -> return $ Function x : cPtr+parseInternal b (APClosure (StgInfoTable 0 0 _ _) _ _ fun pl)+ = parseAPPAP b fun pl -parseInternal b (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _)- = getSetName b >>= \x -> return [Function x]+parseInternal b (PAPClosure (StgInfoTable 0 0 _ _) _ _ fun pl)+ = parseAPPAP b fun pl parseInternal _ (MVarClosure StgInfoTable{} qHead qTail qValue) = do cHead <- liftM mbParens $ contParse qHead@@ -335,7 +353,18 @@ parseInternal _ c = return [Unnamed ("Missing pattern for " ++ show c)] -parseThunkFun :: Box -> [Box] -> [Word] -> PrintState [VisObject]+-- λ> data BinaryTree = BT BinaryTree Int BinaryTree | Leaf deriving Show+-- λ> let x = BT (BT (BT Leaf 1 (BT Leaf 2 Leaf)) 3 (BT (BT Leaf 4 (BT Leaf 5 Leaf)) 6 Leaf))+-- λ> :view x (in list view)+parseAPPAP :: Box -> Box -> [Box] -> MaybeT PrintState [VisObject]+parseAPPAP b fun pl = do+ name <- getSetName b+ fPtr <- contParse fun+ pPtrs <- mapM contParse $ reverse pl+ let tPtrs = intercalate [Unnamed ","] pPtrs+ return $ Function name : fPtr ++ [Unnamed "["] ++ tPtrs ++ [Unnamed "]"]++parseThunkFun :: Box -> [Box] -> [Word] -> MaybeT PrintState [VisObject] parseThunkFun b bPtrs args = do name <- getSetName b cPtrs <- mapM contParse $ reverse bPtrs@@ -344,10 +373,12 @@ Function name : Unnamed "(" : tPtrs ++ [Unnamed ")"] else Function name : (Unnamed $ show args ++ "(") : tPtrs ++ [Unnamed ")"] -contParse :: Box -> PrintState [VisObject]-contParse b = get >>= \(_,h,_) -> parseClosure b (snd $ fromJust1 "5" $ lookup b h)+contParse :: Box -> MaybeT PrintState [VisObject]+contParse b = do (_,h,_) <- lift get+ (_,c) <- lookupT b h+ parseClosure b c -bcoContParse :: [Box] -> PrintState [[VisObject]]+bcoContParse :: [Box] -> MaybeT PrintState [[VisObject]] bcoContParse [] = return [] bcoContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2@@ -356,7 +387,7 @@ ps <- bcoContParse bs return $ p : ps -mutArrContParse :: [Box] -> PrintState [[VisObject]]+mutArrContParse :: [Box] -> MaybeT PrintState [[VisObject]] mutArrContParse [] = return [] mutArrContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of Nothing -> mutArrContParse bs@@ -422,37 +453,49 @@ showClosure (ConsClosure StgInfoTable{} _ dArgs _ _ name) = name ++ show dArgs -showClosure (ArrWordsClosure (StgInfoTable 0 0 ARR_WORDS 0) _ arrWords)- = intercalate ",\n" $ map (printf "0x%x") arrWords--- = "ArrWords"+-- Reversed order of ptrs+showClosure ThunkClosure{}+ = "Thunk" +showClosure SelectorClosure{}+ = "Selector"+ -- Probably should delete these from Graph-showClosure (IndClosure (StgInfoTable 1 0 _ 0) _)+showClosure IndClosure{} = "Ind" -showClosure (BlackholeClosure (StgInfoTable 1 0 _ 0) _)+showClosure BlackholeClosure{} = "Blackhole" --- Reversed order of ptrs-showClosure (ThunkClosure StgInfoTable{} _ _)- = "Thunk"--showClosure (FunClosure StgInfoTable{} _ _)- = "Fun"+showClosure APClosure{}+ = "AP" -showClosure (MutArrClosure StgInfoTable{} _ _ _)- = "MutArr"+showClosure PAPClosure{}+ = "PAP" -showClosure (BCOClosure (StgInfoTable 4 0 BCO 0) _ _ _ _ _ _)+showClosure BCOClosure{} = "BCO" -showClosure (APClosure (StgInfoTable 0 0 _ _) _ _ _ _)- = "AP"+showClosure (ArrWordsClosure (StgInfoTable 0 0 ARR_WORDS 0) _ arrWords)+ = intercalate ",\n" $ map (printf "0x%x") arrWords+-- = "ArrWords" -showClosure (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _)- = "PAP"+showClosure MutArrClosure{}+ = "MutArr" -showClosure (MVarClosure StgInfoTable{} _ _ _)+showClosure MutVarClosure{}+ = "MutVar"++showClosure MVarClosure{} = "MVar#"++showClosure FunClosure{}+ = "Fun"++showClosure BlockingQueueClosure{}+ = "BlockingQueue"++showClosure OtherClosure{}+ = "Other" showClosure c = "Missing pattern for " ++ show c
src/GHC/Vis/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE Rank2Types #-} {- | Module : GHC.Vis.Types Copyright : (c) Dennis Felsing@@ -7,6 +8,7 @@ -} module GHC.Vis.Types ( Signal(..),+ View(..), ViewType(..), State(..), HeapEntry,@@ -18,10 +20,12 @@ import GHC.HeapView -import Graphics.XDot.Types- import qualified Control.Monad.State as MS +import Graphics.UI.Gtk hiding (Box, Signal, Point)++type Point = (Double, Double)+ -- | Signals that are sent to the GUI to signal changes data Signal = NewSignal Box String -- ^ Add a new Box to be visualized | UpdateSignal -- ^ Redraw@@ -29,10 +33,19 @@ | SwitchSignal -- ^ Switch to alternative view | ExportSignal String -- ^ Export the view to a file +-- | All functions a view has to provide+data View = View+ { redraw :: WidgetClass w => w -> IO ()+ , click :: IO ()+ , move :: WidgetClass w => w -> IO ()+ , updateObjects :: [(Box, String)] -> IO ()+ , exportView :: String -> IO ()+ }+ -- | Visualization views data ViewType = ListView | GraphView- deriving (Enum, Eq, Bounded)+ deriving (Enum) -- | The global state used for the visualizations. data State = State
+ src/GHC/Vis/View/Common.hs view
@@ -0,0 +1,65 @@+{- |+ Module : GHC.Vis.View.Common+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.View.Common (+ visSignal,+ visRunning,+ visState,+ visBoxes,+ evaluate+ )+ where++import Control.Concurrent+import Control.DeepSeq++import Data.IORef++import System.IO.Unsafe++import GHC.Vis.Internal+import GHC.Vis.Types+import GHC.HeapView++-- | Communication channel to the visualization+visSignal :: MVar Signal+visSignal = unsafePerformIO (newEmptyMVar :: IO (MVar Signal))++-- | Whether a visualization is currently running+visRunning :: MVar Bool+visRunning = unsafePerformIO (newMVar False)++-- | Internal state of the visualization+visState :: IORef State+visState = unsafePerformIO $ newIORef $ State (0, 0) ListView++-- | All the visualized boxes+visBoxes :: MVar [(Box, String)]+visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [(Box, String)]))++-- | Evaluate an object identified by a String.+evaluate :: String -> IO ()+evaluate identifier = do (_,hm) <- printAll+ show (map go hm) `deepseq` return ()+ where go (Box a,(Just n, y)) | n == identifier = seq a (Just n, y)+ | otherwise = (Just n, y)+ go (_,(x,y)) = (x,y)++--printOne :: a -> IO String+--printOne a = do+-- bs <- readMVar visBoxes+-- case findIndex (\(b,_) -> asBox a == b) bs of+-- Just pos -> do+-- t <- parseBoxes bs+-- return $ show (t !! pos)+-- Nothing -> return "Add entry first"++printAll :: IO (String, HeapMap)+printAll = do+ bs <- readMVar visBoxes+ (t,(_,h,_)) <- parseBoxesHeap bs+ return (show t, h)
+ src/GHC/Vis/View/Graph.hs view
@@ -0,0 +1,164 @@+{- |+ Module : GHC.Vis.View.Graph+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.View.Graph (+ export,+ redraw,+ click,+ move,+ updateObjects+ )+ where++import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, Object)+import qualified Graphics.UI.Gtk as Gtk+import Graphics.Rendering.Cairo++import Control.Concurrent+import Control.Monad++import Data.IORef+import System.IO.Unsafe++import GHC.Vis.View.Graph.Parser+import GHC.Vis.Types hiding (State, View(..))+import GHC.Vis.View.Common++import GHC.HeapView hiding (size)++import Graphics.XDot.Viewer+import Graphics.XDot.Types hiding (size, w, h)++data State = State+ { boxes :: [Box]+ , operations :: [(Object Int, Operation)]+ , totalSize :: (Double, Double, Double, Double)+ , bounds :: [(Object Int, (Double, Double, Double, Double))]+ , hover :: Object Int+ }++state :: IORef State+state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] None++-- | Draw visualization to screen, called on every update or when it's+-- requested from outside the program.+redraw :: WidgetClass w => w -> IO ()+redraw canvas = do+ s <- readIORef state+ Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas++ boundingBoxes <- render canvas (draw s rw2 rh2)++ modifyIORef state (\s' -> s' {bounds = boundingBoxes})++-- | Export the visualization to an SVG file+export :: String -> IO ()+export file = do+ s <- readIORef state++ let (_, _, xSize, ySize) = totalSize s++ withSVGSurface file xSize ySize+ (\surface -> renderWith surface (draw s (round xSize) (round ySize)))++ return ()++draw :: State -> Int -> Int -> Render [(Object Int, Rectangle)]+draw s rw2 rh2 = do+ -- Line widths don't count to size, let's add a bit+ let rw = 0.97 * fromIntegral rw2+ rh = 0.97 * fromIntegral rh2++ ops = operations s+ size@(_,_,sw,sh) = totalSize s++ -- Proportional scaling+ sx = min (rw / sw) (rh / sh)+ sy = sx+ ox = 0.5 * fromIntegral rw2+ oy = 0.5 * fromIntegral rh2++ translate ox oy+ scale sx sy++ result <- drawAll (hover s) size ops++ return $ map (\(o, (x,y,w,h)) -> (o,+ ( x * sx + ox -- Transformations to correct scaling and offset+ , y * sy + oy+ , w * sx+ , h * sy+ ))) result++render :: WidgetClass w => w -> Render b -> IO b+render canvas r = do+ win <- widgetGetDrawWindow canvas+ renderWithDrawable win r++-- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent+-- that causes the object to be evaluated and the screen to be updated.+click :: IO ()+click = do+ s <- readIORef state++ case hover s of+ -- This might fail when a click occurs during an update+ Node t -> unless (length (boxes s) <= t) $ do+ evaluate2 $ boxes s !! t+ -- Without forkIO it would hang indefinitely if some action is currently+ -- executed+ void $ forkIO $ putMVar visSignal UpdateSignal+ _ -> return ()++evaluate2 :: Box -> IO ()+evaluate2 b@(Box a) = do+ c <- getBoxedClosureData b+ case c of+ -- ghc: internal error: MUT_ARR_PTRS_FROZEN object entered!+ -- (GHC version 7.4.2 for x86_64_unknown_linux)+ -- Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug+ --ArrWordsClosure _ _ _ -> return () -- Don't inspect ArrWords+ --MutArrClosure _ _ _ _ -> return ()+ --MVarClosure _ _ _ _ -> return ()+ --_ -> a `seq` return ()+ IndClosure{} -> a `seq` return ()+ BlackholeClosure{} -> a `seq` return ()+ FunClosure{} -> a `seq` return ()+ ThunkClosure{} -> a `seq` return ()+ APClosure{} -> a `seq` return ()+ PAPClosure{} -> a `seq` return ()+ _ -> return ()++-- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a+-- different object now, so the object gets highlighted and the screen+-- updated.+move :: WidgetClass w => w -> IO ()+move canvas = do+ vs <- readIORef visState+ oldS <- readIORef state+ let oldHover = hover oldS++ modifyIORef state $ \s' -> (+ let (mx, my) = mousePos vs+ check (o, (x,y,w,h)) =+ if x <= mx && mx <= x + w &&+ y <= my && my <= y + h+ then o else None++ validOne (None:xs) = validOne xs+ validOne (x:_) = x+ validOne _ = None+ in s' {hover = validOne $ map check (bounds oldS)}+ )+ s <- readIORef state+ unless (oldHover == hover s) $ widgetQueueDraw canvas++-- | Something might have changed on the heap, update the view.+updateObjects :: [(Box, String)] -> IO ()+updateObjects bs = do+ (ops, bs', size) <- xDotParse bs+ modifyIORef state (\s -> s {operations = ops, boxes = bs', totalSize = size, hover = None})
+ src/GHC/Vis/View/Graph/Parser.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+ Module : GHC.Vis.View.Graph.Parser+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.View.Graph.Parser (+ xDotParse+)+where++import Control.Monad++import qualified Data.Text.Lazy as B++import Data.Graph.Inductive hiding (nodes, edges)++import Data.GraphViz hiding (Ellipse, Polygon, parse)+import Data.GraphViz.Attributes.Complete+import Data.GraphViz.Commands.IO++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 = "Times Roman"+--fontName = "Helvetica"+fontName = "Sans"++graphFontSize :: Double+graphFontSize = 24++nodeFontSize :: Double+nodeFontSize = 24++edgeFontSize :: Double+edgeFontSize = 24++foldlMaybe :: (a -> b -> Maybe a) -> a -> [b] -> Maybe a+foldlMaybe f a bs =+ foldr (\b g x -> f x b >>= g) Just bs a++-- | Take the objects to be visualized and run them through @dot@ and extract+-- the drawing operations that have to be exectued to show the graph of the+-- heap map.+xDotParse :: [(Box, String)] -> IO ([(Object Node, Operation)], [Box], Rectangle)+xDotParse as = do+ hm <- walkHeap as++ let nodes = zip [0..] $ map (\(_,(_,c)) -> c) rhm+ edges = do+ mbe <- foldM mbEdges [] nodes+ return $ foldlMaybe toLEdge [] mbe+ -- Reversing it fixes the ordering of nodes in the graph. Should run+ -- through allPtrs and sort by order inside of all allPtrs lists.+ --+ -- When building the graph directly out of [Box] instead of going+ -- through the HeapMap, then the order of nodes might not be right for+ -- non-trivial graphs.+ --+ -- In some cases it's impossible to get the order right. Maybe there is+ -- a way in graphviz to specify outgoing edge orientation after all?+ rhm = reverse hm++ toLEdge xs (0, Just t) = if length rhm <= t+ then Nothing -- This might be able to happen, let's make sure it doesn't+ else case rhm !! t of+ (_,(Just name, _)) -> Just $ (0,t,name):xs+ (_,(Nothing, _)) -> Just $ (0,t,""):xs+ toLEdge xs (f, Just t) = Just $ (f,t,""):xs+ toLEdge xs _ = Just xs++ mbEdges xs (p,BCOClosure _ _ _ bPtr _ _ _) = do+ children <- bcoChildren [bPtr]+ return $ map (\b -> (p, Just b)) children ++ xs+ -- Using allPtrs and then filtering the closures not available in the+ -- heap map out emulates pointersToFollow without being in IO+ mbEdges xs (p,c) = return $ map (\b -> (p, boxPos b)) (allPtrs c) ++ xs++ boxPos :: Box -> Maybe Int+ boxPos b = lookup b $ zip (map fst rhm) [0..]++ bcoChildren :: [Box] -> IO [Int]+ bcoChildren [] = return []+ bcoChildren (b:bs) = case boxPos b of+ --Nothing -> let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2+ -- in bcoChildren (ptf ++ bs) h -- Could go into infinite loop+ Nothing -> do c <- getBoxedClosureData b+ ptf <- pointersToFollow2 c+ bcoChildren (ptf ++ bs)+ Just pos -> do children <- bcoChildren bs+ return $ pos : children++ es' <- edges++ case es' of+ Nothing -> xDotParse as+ Just es -> do+ -- Convert a heap map, our internal data structure, to a graph that can be+ -- converted to a dot graph.+ let buildGraph :: Gr Closure String+ buildGraph = insEdges es $ insNodes nodes empty++ xDot <- graphvizWithHandle Dot (defaultVis $ toViewableGraph buildGraph) XDot hGetDot+ return (getOperations xDot, getBoxes hm, getSize xDot)++getBoxes :: HeapMap -> [Box]+getBoxes hm = map (\(b,(_,_)) -> b) $ reverse hm++-- Probably have to do some kind of fold over the graph to remove for example+-- unwanted pointers+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+ -- Somehow (X11Color Transparency) is white, use (RGBA 0 0 0 0) instead+ { globalAttributes = [GraphAttrs [BgColor [RGBA 0 0 0 0], FontName fontName, FontSize graphFontSize]]+ , fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize]+ --, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize, Shape PlainText]+ , fmtEdge = \ (_,_,l) -> [toLabel l, FontName fontName, FontSize edgeFontSize]+ }
+ src/GHC/Vis/View/List.hs view
@@ -0,0 +1,376 @@+{- |+ Module : GHC.Vis.View.List+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.View.List (+ export,+ redraw,+ click,+ move,+ updateObjects+ )+ where+import Graphics.UI.Gtk hiding (Box, Signal, Rectangle)+import qualified Graphics.UI.Gtk as Gtk+import Graphics.Rendering.Cairo++import Control.Concurrent+import Control.Monad++import Data.IORef+import System.IO.Unsafe++import GHC.Vis.Internal+import GHC.Vis.Types hiding (State, View(..))+import GHC.Vis.View.Common++import GHC.HeapView (Box)++type Rectangle = (Double, Double, Double, Double)++data State = State+ { objects :: [(Box, String, [VisObject])]+ , bounds :: [(String, Rectangle)]+ , hover :: Maybe String+ }++type RGB = (Double, Double, Double)++state :: IORef State+state = unsafePerformIO $ newIORef $ State [] [] Nothing++fontName :: String+fontName = "Sans"+--fontName = "Times Roman"+--fontName = "DejaVu Sans"+--fontName = "Lucida Grande"++fontSize :: Double+fontSize = 15++colorName :: RGB+colorName = (0.5,1,0.5)++colorNameHighlighted :: RGB+colorNameHighlighted = (0,1,0)++colorLink :: RGB+colorLink = (0.5,0.5,1)++colorLinkHighlighted :: RGB+colorLinkHighlighted = (0.25,0.25,1)++colorFunction :: RGB+colorFunction = (1,0.5,0.5)++colorFunctionHighlighted :: RGB+colorFunctionHighlighted = (1,0,0)++padding :: Double+padding = 5++-- | Draw visualization to screen, called on every update or when it's+-- requested from outside the program.+redraw :: WidgetClass w => w -> IO ()+redraw canvas = do+ s <- readIORef state+ Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas++ boundingBoxes <- render canvas (draw s rw2 rh2)+ modifyIORef state (\s' -> s' {bounds = boundingBoxes})++-- | Export the visualization to an SVG file+export :: String -> IO ()+export file = do+ s <- readIORef state++ withSVGSurface file (fromIntegral xSize) (fromIntegral ySize)+ (\surface -> renderWith surface (draw s xSize ySize))++ return ()++ where xSize = 500 :: Int+ ySize = 500 :: Int++draw :: State -> Int -> Int -> Render [(String, Rectangle)]+draw s rw2 rh2 = do+ let os = objects s+ objs = map (\(_,_,x) -> x) os+ --boxes = map (\(x,_,_) -> x) os+ names = map ((++ ": ") . (\(_,x,_) -> x)) os++ nameWidths <- mapM (width . Unnamed) names+ pos <- mapM height objs+ widths <- mapM (mapM width) objs++ -- Text sizes aren't always perfect, assume that texts may be a bit too big+ -- TODO: This doesn't work for small font sizes+ let rw = 0.9 * fromIntegral rw2+ rh = fromIntegral rh2++ maxNameWidth = maximum nameWidths+ widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths++ sw = maximum widths2+ sh = sum (map (+ 30) pos) - 15++ sx = min (rw / sw) (rh / sh)+ sy = sx+ ox = 0+ oy = 0++ translate ox oy+ scale sx sy++ --nameWidths <- mapM (width . Unnamed) names+ --widths <- mapM (mapM width) objs+ --let maxNameWidth = maximum nameWidths+ -- widths2 = 1 : map (\ws -> maxNameWidth + sum ws) widths+ -- sw2 = maximum widths2+ --scale (0.9 * rw / (sw2 * sx)) (0.9 * rw / (sw2 * sx))+ --liftIO $ putStrLn $ show rw2+ --liftIO $ putStrLn $ show $ sw2 * sx+ --liftIO $ putStrLn "--"++ let rpos = scanl (\a b -> a + b + 30) 30 pos+ result <- mapM (drawEntry s maxNameWidth) (zip3 objs rpos names)++ return $ map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result++render :: WidgetClass w => w -> Render b -> IO b+render canvas r = do+ win <- widgetGetDrawWindow canvas+ renderWithDrawable win r++-- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent+-- that causes the object to be evaluated and the screen to be updated.+click :: IO ()+click = do+ s <- readIORef state++ case hover s of+ Just t -> do+ evaluate t+ -- Without forkIO it would hang indefinitely if some action is currently+ -- executed+ void $ forkIO $ putMVar visSignal UpdateSignal+ _ -> return ()++-- | Handle a mouse move. Causes an 'UpdateSignal' if the mouse is hovering a+-- different object now, so the object gets highlighted and the screen+-- updated.+move :: WidgetClass w => w -> IO ()+move canvas = do+ vS <- readIORef visState+ oldS <- readIORef state+ let oldHover = hover oldS++ modifyIORef state $ \s' -> (+ let (mx, my) = mousePos vS+ check (o, (x,y,w,h)) =+ if x <= mx && mx <= x + w &&+ y <= my && my <= y + h+ then Just o else Nothing+ in s' {hover = msum $ map check (bounds s')}+ )+ s <- readIORef state+ unless (oldHover == hover s) $ widgetQueueDraw canvas++-- | Something might have changed on the heap, update the view.+updateObjects :: [(Box, String)] -> IO ()+updateObjects boxes = do+ os <- parseBoxes boxes+ let objs = zipWith (\(x,y) z -> (x,y,z)) boxes os+ modifyIORef state (\s -> s {objects = objs, hover = Nothing})++drawEntry :: State -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]+drawEntry s nameWidth (obj, pos, name) = do+ save+ translate 0 pos+ moveTo 0 0+ drawBox s $ Unnamed name+ translate nameWidth 0+ moveTo 0 0+ boundingBoxes <- mapM (drawBox s) obj+ restore+ return $ map (\(o, (x,y,w,h)) -> (o, (x+nameWidth,y+pos,w,h))) $ concat boundingBoxes++drawBox :: State -> VisObject -> Render [(String, Rectangle)]+drawBox _ o@(Unnamed content) = do+ (x,_) <- getCurrentPoint+ wc <- width o++ (layout, metrics) <- pangoLayout content+ let fa = ascent metrics++ moveTo (x + padding/2) (-fa)+ setSourceRGB 0 0 0+ showLayout layout+ moveTo (x + wc) 0++ return []++drawBox s o@(Function target) =+ drawFunctionLink s o target colorFunction colorFunctionHighlighted++drawBox s o@(Link target) =+ drawFunctionLink s o target colorLink colorLinkHighlighted++drawBox s o@(Named name content) = do+ (x,_) <- getCurrentPoint++ hc <- height content+ wc <- width o++ (layout, metrics) <- pangoLayout name+ (_, PangoRectangle _ _ xa fh) <- liftIO $ layoutGetExtents layout+ let fa = ascent metrics++ let (ux, uy, uw, uh) =+ ( x+ , -fa - padding+ , wc+ , fh + 10 + hc+ )++ setLineCap LineCapRound+ roundedRect ux uy uw uh++ setColor s name colorName colorNameHighlighted++ fillAndSurround++ moveTo ux (hc + 5 - fa - padding)+ lineTo (ux + uw) (hc + 5 - fa - padding)+ stroke++ save+ moveTo (x + padding) 0+ bb <- mapM (drawBox s) content+ restore++ moveTo (x + uw/2 - xa/2) (hc + 7.5 - padding - fa)+ showLayout layout+ moveTo (x + wc) 0++ return $ concat bb ++ [(name, (ux, uy, uw, uh))]++pangoLayout :: String -> Render (PangoLayout, FontMetrics)+pangoLayout text = do+ layout <- createLayout text+ context <- liftIO $ layoutGetContext layout++ --fo <- liftIO $ cairoContextGetFontOptions context++ --fontOptionsSetAntialias fo AntialiasDefault+ --fontOptionsSetHintStyle fo HintStyleNone+ --fontOptionsSetHintMetrics fo HintMetricsOff+ --liftIO $ cairoContextSetFontOptions context fo++ --liftIO $ layoutContextChanged layout++ -- This does not work with "Times Roman", but it works with a font that is+ -- installed on the system+ --font <- liftIO fontDescriptionNew+ --liftIO $ fontDescriptionSetFamily font "Nimbus Roman No9 L, Regular"+ --liftIO $ fontDescriptionSetFamily font "Times Roman"+ --liftIO $ fontDescriptionSetSize font fontSize'++ -- Only fontDescriptionFromString works as expected, choosing a similar+ -- alternative font when the selected one is not available+ font <- liftIO $ fontDescriptionFromString fontName+ liftIO $ fontDescriptionSetSize font fontSize+ liftIO $ layoutSetFontDescription layout (Just font)++ language <- liftIO $ contextGetLanguage context+ metrics <- liftIO $ contextGetMetrics context font language++ return (layout, metrics)++drawFunctionLink :: State -> VisObject -> String -> RGB -> RGB -> Render [(String, Rectangle)]+drawFunctionLink s o target color1 color2 = do+ (x,_) <- getCurrentPoint+ (layout, metrics) <- pangoLayout target+ (_, PangoRectangle _ _ _ fh) <- liftIO $ layoutGetExtents layout+ let fa = ascent metrics++ wc <- width o++ let (ux, uy, uw, uh) =+ ( x+ , (-fa) - padding+ , wc+ , fh + 10+ )++ setLineCap LineCapRound+ roundedRect ux uy uw uh++ setColor s target color1 color2++ fillAndSurround++ moveTo (x + padding) (-fa)+ showLayout layout+ moveTo (x + wc) 0++ return [(target, (ux, uy, uw, uh))]++setColor :: State -> String -> RGB -> RGB -> Render ()+setColor s name (r,g,b) (r',g',b') = case hover s of+ Just t -> if t == name then setSourceRGB r' g' b'+ else setSourceRGB r g b+ _ -> setSourceRGB r g b++fillAndSurround :: Render ()+fillAndSurround = do+ fillPreserve+ setSourceRGB 0 0 0+ stroke++roundedRect :: Double -> Double -> Double -> Double -> Render ()+roundedRect x y w h = do+ moveTo x (y + pad)+ lineTo x (y + h - pad)+ arcNegative (x + pad) (y + h - pad) pad pi (pi/2)+ lineTo (x + w - pad) (y + h)+ arcNegative (x + w - pad) (y + h - pad) pad (pi/2) 0+ lineTo (x + w) (y + pad)+ arcNegative (x + w - pad) (y + pad) pad 0 (-pi/2)+ lineTo (x + pad) y+ arcNegative (x + pad) (y + pad) pad (-pi/2) (-pi)+ closePath++ --where pad = 1/10 * min w h+ where pad = 5++height :: [VisObject] -> Render Double+height xs = do+ (layout, _) <- pangoLayout ""+ (_, PangoRectangle _ _ _ ya) <- liftIO $ layoutGetExtents layout+ let go (Named _ ys) = (ya + 15) + maximum (map go ys)+ go (Unnamed _) = ya+ go (Link _) = ya + 2 * padding+ go (Function _) = ya + 2 * padding+ return $ maximum $ map go xs++width :: VisObject -> Render Double+width (Named x ys) = do+ nameWidth <- simpleWidth x $ 2 * padding+ w2s <- mapM width ys+ return $ max nameWidth $ sum w2s + 2 * padding++width (Unnamed x) = simpleWidth x padding++width (Link x) = simpleWidth x $ 2 * padding++width (Function x) = simpleWidth x $ 2 * padding++simpleWidth :: String -> Double -> Render Double+simpleWidth x pad = do+ (layout, _) <- pangoLayout x+ (_, PangoRectangle _ _ xa _) <- liftIO $ layoutGetExtents layout+ return $ xa + pad