diff --git a/ghc-vis.cabal b/ghc-vis.cabal --- a/ghc-vis.cabal +++ b/ghc-vis.cabal @@ -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 diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs --- a/src/GHC/Vis.hs +++ b/src/GHC/Vis.hs @@ -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) diff --git a/src/GHC/Vis/GTK/Common.hs b/src/GHC/Vis/GTK/Common.hs deleted file mode 100644 --- a/src/GHC/Vis/GTK/Common.hs +++ /dev/null @@ -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) - diff --git a/src/GHC/Vis/GTK/Graph.hs b/src/GHC/Vis/GTK/Graph.hs deleted file mode 100644 --- a/src/GHC/Vis/GTK/Graph.hs +++ /dev/null @@ -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}) diff --git a/src/GHC/Vis/GTK/List.hs b/src/GHC/Vis/GTK/List.hs deleted file mode 100644 --- a/src/GHC/Vis/GTK/List.hs +++ /dev/null @@ -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 diff --git a/src/GHC/Vis/Graph.hs b/src/GHC/Vis/Graph.hs deleted file mode 100644 --- a/src/GHC/Vis/Graph.hs +++ /dev/null @@ -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] - } diff --git a/src/GHC/Vis/Internal.hs b/src/GHC/Vis/Internal.hs --- a/src/GHC/Vis/Internal.hs +++ b/src/GHC/Vis/Internal.hs @@ -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 diff --git a/src/GHC/Vis/Types.hs b/src/GHC/Vis/Types.hs --- a/src/GHC/Vis/Types.hs +++ b/src/GHC/Vis/Types.hs @@ -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 diff --git a/src/GHC/Vis/View/Common.hs b/src/GHC/Vis/View/Common.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/View/Common.hs @@ -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) diff --git a/src/GHC/Vis/View/Graph.hs b/src/GHC/Vis/View/Graph.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/View/Graph.hs @@ -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}) diff --git a/src/GHC/Vis/View/Graph/Parser.hs b/src/GHC/Vis/View/Graph/Parser.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/View/Graph/Parser.hs @@ -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] + } diff --git a/src/GHC/Vis/View/List.hs b/src/GHC/Vis/View/List.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Vis/View/List.hs @@ -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