ghc-vis (empty) → 0.1
raw patch · 11 files changed
+1472/−0 lines, 11 filesdep +basedep +cairodep +deepseqsetup-changed
Dependencies added: base, cairo, deepseq, fgl, ghc-heap-view, graphviz, gtk, mtl, text, xdot
Files
- LICENSE +30/−0
- Setup.hs +3/−0
- ghc-vis.cabal +98/−0
- ghci +12/−0
- src/GHC/Vis.hs +139/−0
- src/GHC/Vis/GTK/Common.hs +68/−0
- src/GHC/Vis/GTK/Graph.hs +157/−0
- src/GHC/Vis/GTK/List.hs +324/−0
- src/GHC/Vis/Graph.hs +113/−0
- src/GHC/Vis/Internal.hs +458/−0
- src/GHC/Vis/Types.hs +70/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012 Dennis Felsing++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main = defaultMain
+ ghc-vis.cabal view
@@ -0,0 +1,98 @@+name: ghc-vis+version: 0.1+license: BSD3+license-file: LICENSE+category: GHC, Debug, Development+cabal-version: >= 1.10+build-type: Simple+author: Dennis Felsing <dennis@felsin9.de>+maintainer: Dennis Felsing <dennis@felsin9.de>+homepage: http://felsin9.de/nnis/ghc-vis+copyright: Dennis Felsing 2012+synopsis: Live visualization of data structures in GHCi+description: Visualize live data structures in GHCi. Evaluation is not+ forced and you can interact with the visualized data+ structures. This allows seeing Haskell's lazy evaluation+ and sharing in action.+ .+ To use this package add the accompanying @ghci@ file to+ your @.ghci@ like this:+ .+ > echo ":script $HOME/.cabal/share/ghc-vis-0.1/ghci" >> ~/.ghci+ .+ Now you can run ghci and experiment with @ghc-vis@. Start+ the visualization:+ .+ > $ ghci+ > GHCi, version 7.4.2: http://www.haskell.org/ghc/ :? for help+ > > :vis+ .+ A blank window should appear now. This is the visualization+ window. Add an expression to the visualization:+ .+ > > let a = [1..3]+ > > :view a+ > > let b = cycle a+ > > :view b+ > > :view "foo" ++ "bar"+ .+ <http://felsin9.de/nnis/ghc-vis/1.png>+ .+ Functions are red, named objects are green and links to an+ already shown object are blue.+ .+ Notice how @a@ is referenced by @b@.+ .+ Evaluate an object that is shown in the visualization. You+ can also click on the object to evaluate it.+ .+ > > :eval t1+ .+ <http://felsin9.de/nnis/ghc-vis/2.png>+ .+ The first element of @b@ has been evaluated. We see that+ it's a reference to the value that's also referenced in a,+ as they share the same name "t0".+ .+ Switch between the list view and the graph view:+ .+ > > :switch+ .+ <http://felsin9.de/nnis/ghc-vis/3.png>+ .+ When an object is updated by accessing it, you have to call+ @:update@ to refresh the visualization window. You can also+ click on an object to force an update:+ .+ > > a !! 2+ > 3+ > > :update+ .+ <http://felsin9.de/nnis/ghc-vis/4.png>+ .+ Clear the visualization window, this also happens when you+ @:load@ or @:reload@ a source file:+ .+ > > :clear++data-files: ghci++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+ Default-Language: Haskell2010+ Build-depends: base == 4.5.*,+ fgl,+ mtl,+ deepseq,+ ghc-heap-view >= 0.3,+ cairo,+ gtk,+ graphviz,+ text,+ xdot+ Hs-source-dirs: src/+ Ghc-options: -Wall -fno-warn-unused-do-bind++--source-repository head+-- type: darcs+-- location: http://
+ ghci view
@@ -0,0 +1,12 @@+let _put s = "System.Timeout.timeout 1000000 (Control.Concurrent.MVar.putMVar GHC.Vis.visSignal $ GHC.Vis.Types." ++ s ++ ") >> return ()"++:def vis \_ -> return $ "GHC.Vis.visualization"+:def view \x -> return $ _put $ "NewSignal (GHC.HeapView.asBox (" ++ x ++ ")) " ++ show x+:def eval \x -> return $ "GHC.Vis.evaluate \"" ++ x ++ "\"\n" ++ _put "UpdateSignal"+:def switch \_ -> return $ _put "SwitchSignal"+:def update \_ -> return $ _put "UpdateSignal"+:def clear \_ -> return $ _put "ClearSignal"+:def export \x -> return $ _put $ "ExportSignal " ++ show x++-- Remove our temporary bindings+-- :r
+ src/GHC/Vis.hs view
@@ -0,0 +1,139 @@+{- |+ Module : GHC.Vis+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de+ -}+module GHC.Vis (+ visualization,+ visSignal,+ evaluate+ )+ where++import Prelude hiding (catch)++import Graphics.UI.Gtk hiding (Box, Signal)+import qualified Graphics.UI.Gtk.Gdk.Events as E++import System.IO+import Control.Concurrent+import Control.Monad++import Control.Exception hiding (evaluate)++import Data.IORef++import System.Timeout+import System.Mem++import GHC.Vis.Types+import GHC.Vis.GTK.Common+import qualified GHC.Vis.GTK.Graph as Graph+import qualified GHC.Vis.GTK.List as List++title :: String+title = "ghc-vis"++backgroundColor :: Color+backgroundColor = Color 0xffff 0xffff 0xffff++defaultSize :: (Int, Int)+defaultSize = (640, 480)++signalTimeout :: Int+signalTimeout = 1000000++-- | This is the main function. It's to be called from GHCi and launches a+-- graphical window in a new thread.+visualization :: IO ()+visualization = do+ vr <- swapMVar visRunning True+ unless vr $ void $ forkIO visMainThread++visMainThread :: IO ()+visMainThread = do+ initGUI+ window <- windowNew++ canvas <- drawingAreaNew++ widgetModifyBg canvas StateNormal backgroundColor++ set window [ windowTitle := title+ , containerChild := canvas+ ]+ (uncurry $ windowSetDefaultSize window) defaultSize++ onExpose canvas $ const $ do+ runCorrect Graph.redraw List.redraw >>= \f -> f canvas+ runCorrect Graph.move List.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+ return True++ onButtonPress canvas $ \e -> do+ click <- runCorrect Graph.click List.click+ when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) click+ return True++ widgetShowAll window++ reactThread <- forkIO $ react canvas window+ --onDestroy window mainQuit -- Causes :r problems with multiple windows+ onDestroy window (quit reactThread)++ mainGUI+ return ()++quit :: ThreadId -> IO ()+quit reactThread = do+ swapMVar visRunning False+ killThread reactThread++react :: (WidgetClass w1, WidgetClass w2) => w1 -> w2 -> IO b+react canvas window = do+ -- Timeout used to handle ghci reloads (:r)+ -- Reloads cause the visSignal to be reinitialized, but takeMVar is still+ -- waiting for the old one. This solution is not perfect, but it works for+ -- now.+ mbSignal <- timeout signalTimeout (takeMVar visSignal)+ case mbSignal of+ Nothing -> do+ running <- readMVar visRunning+ if running then react canvas window else+ -- :r caused visRunning to be reset+ (do swapMVar visRunning True+ putMVar visSignal UpdateSignal+ react canvas window)+ Just signal -> do+ case signal of+ NewSignal x n -> modifyMVar_ visBoxes (+ \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 {view = succN (view s)})+ ExportSignal f -> catch (runCorrect Graph.export List.export >>= \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?++ runCorrect Graph.updateObjects List.updateObjects >>= \f -> f boxes++ postGUISync $ widgetQueueDraw canvas+ react canvas window++ where succN v = if v == maxBound then minBound else succ v++runCorrect :: f -> f -> IO f+runCorrect f1 f2 = do+ s <- readIORef visState+ return $ case view s of+ GraphView -> f1+ ListView -> f2
+ src/GHC/Vis/GTK/Common.hs view
@@ -0,0 +1,68 @@+{- |+ 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 view
@@ -0,0 +1,157 @@+{- |+ 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 view
@@ -0,0 +1,324 @@+{- |+ 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 view
@@ -0,0 +1,113 @@+{-# 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
@@ -0,0 +1,458 @@+{-# LANGUAGE MagicHash #-}++{- |+ Module : GHC.Vis.Internal+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.Internal (+ walkHeap,+ --walkHeapDepth,+ parseBoxes,+ parseBoxesHeap,+ --parseClosure,+ --pointersToFollow,+ pointersToFollow2,+ showClosure+ )+ where++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 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++-- | 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++generalParseBoxes :: Num t =>+ (PrintState [[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+ r <- parseClosure b' c+ rs <- go b's+ --return (r:rs)+ return (simplify r:rs)+ go [] = return []++-- Pulls together multiple Unnamed objects to one+simplify :: [VisObject] -> [VisObject]+simplify [] = []+simplify [Named a bs] = [Named a $ simplify bs]+simplify [a] = [a]+simplify (Unnamed a : Unnamed b : xs) = simplify $ Unnamed (a ++ b) : xs+simplify (Named a bs : xs) = Named a (simplify bs) : simplify xs+simplify (a:xs) = a : simplify xs++parseClosure :: Box -> Closure -> PrintState [VisObject]+parseClosure b c = do+ o <- correctObject b+ case o of+ Link n -> return [Link n] -- Don't build infinite heaps+ _ -> 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 = do+ r <- 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+ return $ Named name [])+ else return $ Unnamed ""++insertObjects :: VisObject -> [VisObject] -> [VisObject]+insertObjects _ xs@(Function _ : _) = xs+insertObjects (Link name) _ = [Link name]+insertObjects (Named name _) xs = [Named name xs]+insertObjects (Unnamed _) xs = xs+insertObjects _ _ = error "unexpected arguments"++-- | Recursively walk down the heap objects and return the resulting map. This+-- function recognizes loops and avoids them. Big data structures might still+-- be very slow.+walkHeap :: [(Box, String)] -> IO HeapMap+walkHeap = walkHeapGeneral Just pointersToFollow++-- walkHeap, but without Top level names+walkHeapSimply :: [(Box, String)] -> IO HeapMap+walkHeapSimply = walkHeapGeneral (const Nothing) pointersToFollow++walkHeapWithBCO :: [(Box, String)] -> IO HeapMap+walkHeapWithBCO = walkHeapGeneral (const Nothing) pointersToFollow2++walkHeapGeneral :: (String -> Maybe String) -> (Closure -> IO [Box]) -> [(Box, String)] -> IO HeapMap+walkHeapGeneral topF p2fF bs = foldM (topNodes topF) [dummy] bs >>= \s -> foldM (startWalk p2fF) s bs+ where topNodes hn l (b,n) = do -- Adds the top nodes without looking at their pointers+ c' <- getBoxedClosureData b+ return $ insert (b, (hn n, c')) l+ startWalk p2f l (b,_) = do -- Ignores that the top nodes are already in the heap map+ c' <- getBoxedClosureData b+ p <- p2f c'+ foldM (step p2f) l p+ step p2f l b = case lookup b l of+ Just _ -> return l+ Nothing -> do+ c' <- getBoxedClosureData b+ p <- p2f c'+ foldM (step p2f) (insert (b, (Nothing, c')) l) p+ dummy = (asBox (1 :: Integer),+ (Nothing, ConsClosure (StgInfoTable 0 0 CONSTR_0_1 0) (map fst bs) [] "" "" ""))++-- Don't inspect deep pointers in BCOClosures for now, they never end++-- New: We're not inspecting the BCOs and instead later looks which of its+-- recursive children are still in the heap. Only those should be visualized.+pointersToFollow :: Closure -> IO [Box]+pointersToFollow (BCOClosure StgInfoTable{} _ _ _ _ _ _) = return []++pointersToFollow (MutArrClosure StgInfoTable{} _ _ bPtrs) =+ do cPtrs <- mapM getBoxedClosureData bPtrs+ return $ fix $ zip bPtrs cPtrs+ where fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs+ fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs+ fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):xs) = fix xs+ fix ((x,_):xs) = x : fix xs+ fix [] = []++pointersToFollow x = return $ allPtrs x++-- | Follows 'GHC.HeapView.BCOClosure's, but not the debugging data structures+-- (ByteCodeInstr.BreakInfo) of GHC.+pointersToFollow2 :: Closure -> IO [Box]+pointersToFollow2 (MutArrClosure StgInfoTable{} _ _ bPtrs) =+ do cPtrs <- mapM getBoxedClosureData bPtrs+ return $ fix $ zip bPtrs cPtrs+ where fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs+ fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs+ fix ((_,ConsClosure StgInfoTable{} _ _ _ "ByteCodeInstr" "BreakInfo"):xs) = fix xs+ fix ((x,_):xs) = x : fix xs+ fix [] = []++pointersToFollow2 x = return $ allPtrs x++-- walkHeap, but with a maximum depth+--walkHeapDepth :: [(Box, String)] -> IO HeapMap+--walkHeapDepth bs = foldM topNodes [dummy bs] bs >>= \s -> foldM goStart s bs+-- where topNodes l (b,n) = do -- Adds the top nodes without looking at their pointers+-- c' <- getBoxedClosureData b+-- return $ insert (b, (Just n, c')) l+-- goStart l (b,_) = do -- Ignores that the top nodes are already in the heap map+-- c' <- getBoxedClosureData b+-- p <- pointersToFollow c'+-- foldM (\l b -> go l b 30) l p+-- go l _ 0 = return l+-- go l b x = case lookup b l of+-- Just _ -> return l+-- Nothing -> do+-- c' <- getBoxedClosureData b+-- p <- pointersToFollow c'+-- foldM (\l b -> go l b (x-1)) (insert (b, (Nothing, c')) l) p++-- Additional map operations+insert :: (Box, HeapEntry) -> HeapMap -> HeapMap+insert (b,x) xs = case find (\(c,_) -> c == b) xs of+ 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++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)+ set _ _ = error "unexpected pattern"++getName :: Box -> PrintState (Maybe String)+getName b = do (_,h,_) <- get+ return $ fst $ fromJust1 "3" $ lookup b h++getSetName :: Box -> PrintState String+getSetName b = do mn <- getName b+ case mn of+ Nothing -> do setName b+ n <- getName b+ return $ fromJust1 "4" n+ Just name -> return name++-- How often is a box referenced in the entire heap map+countReferences :: Box -> PrintState Int+countReferences b = do+ (_,_,h) <- get+ return $ sum $ map countR h+ where countR (_,(_,c)) = length $ filter (== b) $ allPtrs c++parseInternal :: Box -> Closure -> PrintState [VisObject]+parseInternal _ (ConsClosure StgInfoTable{} _ [dataArg] _pkg modl name) =+ return [Unnamed $ case (modl, name) of+ k | k `elem` [ ("GHC.Word", "W#")+ , ("GHC.Word", "W8#")+ , ("GHC.Word", "W16#")+ , ("GHC.Word", "W32#")+ , ("GHC.Word", "W64#")+ ] -> show dataArg++ k | k `elem` [ ("GHC.Integer.Type", "S#")+ , ("GHC.Types", "I#")+ , ("GHC.Int", "I8#")+ , ("GHC.Int", "I16#")+ , ("GHC.Int", "I32#")+ , ("GHC.Int", "I64#")+ ] -> show $ (fromIntegral :: Word -> Int) dataArg++ ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg++ ("Types", "D#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)+ ("Types", "F#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)++ (_,name') -> printf "%s[%d]" name' dataArg+ ]++-- Empty ByteStrings point to a nullForeignPtr, evaluating it leads to an+-- Prelude.undefined exception+parseInternal _ (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS")+ = return [Unnamed "ByteString[0,0]()"]++parseInternal _ (ConsClosure (StgInfoTable 1 3 _ 0) [bPtr] [_,start,end] _ "Data.ByteString.Internal" "PS")+ = do cPtr <- contParse bPtr+ return $ Unnamed (printf "ByteString[%d,%d](" start end) : cPtr ++ [Unnamed ")"]++parseInternal _ (ConsClosure (StgInfoTable 2 3 _ 1) [bPtr1,bPtr2] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk")+ = do cPtr1 <- contParse bPtr1+ cPtr2 <- contParse bPtr2+ return $ Unnamed (printf "Chunk[%d,%d](" start end) : cPtr1 ++ [Unnamed ","] ++ cPtr2 ++ [Unnamed ")"]++parseInternal _ (ConsClosure (StgInfoTable 1 0 CONSTR_1_0 _) [bPtr] [] _ _ name)+ = do cPtr <- contParse bPtr+ return $ Unnamed (name ++ " ") : mbParens cPtr++parseInternal _ (ConsClosure (StgInfoTable 0 0 CONSTR_NOCAF_STATIC _) [] [] _ _ name)+ = return [Unnamed name]++parseInternal _ (ConsClosure (StgInfoTable 0 _ CONSTR_NOCAF_STATIC _) [] args _ _ name)+ = return [Unnamed (name ++ " " ++ show args)]++parseInternal _ (ConsClosure (StgInfoTable 2 0 _ 1) [bHead,bTail] [] _ "GHC.Types" ":")+ = do cHead <- liftM mbParens $ contParse bHead+ cTail <- liftM mbParens $ contParse bTail+ return $ cHead ++ [Unnamed ":"] ++ cTail++parseInternal _ (ConsClosure (StgInfoTable _ 0 _ _) bPtrs [] _ _ name)+ = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs+ let tPtrs = intercalate [Unnamed " "] cPtrs+ return $ Unnamed (name ++ " ") : tPtrs++parseInternal _ (ConsClosure (StgInfoTable _ _ _ _) bPtrs dArgs _ _ name)+ = do cPtrs <- mapM (liftM mbParens . contParse) bPtrs+ let tPtrs = intercalate [Unnamed " "] cPtrs+ return $ Unnamed (name ++ show dArgs ++ " ") : tPtrs++parseInternal _ (ArrWordsClosure (StgInfoTable 0 0 ARR_WORDS 0) _ arrWords)+ = return $ intercalate [Unnamed ","] (map (\x -> [Unnamed (printf "0x%x" x)]) arrWords)++parseInternal _ (IndClosure (StgInfoTable 1 0 _ 0) b)+ = contParse b++parseInternal _ (BlackholeClosure (StgInfoTable 1 0 _ 0) b)+ = contParse b++-- Reversed order of ptrs+parseInternal b (ThunkClosure StgInfoTable{} bPtrs args)+ = parseThunkFun b bPtrs args++parseInternal b (FunClosure StgInfoTable{} bPtrs args)+ = parseThunkFun b bPtrs args++-- bPtrs here can currently point to Nothing, because else we might get infinite heaps+parseInternal _ (MutArrClosure StgInfoTable{} _ _ bPtrs)+ = do cPtrs <- mutArrContParse bPtrs+ let tPtrs = intercalate [Unnamed ","] cPtrs+ return $ Unnamed "(" : tPtrs ++ [Unnamed ")"]++parseInternal _ (BCOClosure (StgInfoTable 4 0 BCO 0) _ _ bPtr _ _ _)+ = do cPtrs <- bcoContParse [bPtr]+ let tPtrs = intercalate [Unnamed ","] cPtrs+ return $ Unnamed "(" : tPtrs ++ [Unnamed ")"]+ -- = do case lookup b h of+ -- Nothing -> c <- getBoxedClosureData bPtr+ -- Just (_,c) -> p <- parseClosure bPtr c+ -- = do vs <- contParse bPtr+ -- let ls = filter isExternal $ filter isLink vs++ -- isLink (Link _) = True+ -- isLink _ = False++ -- isExternal (Link n) = all (notHasName n) vs++ -- notHasName n (Named m _) = n /= m+ -- notHasName n (Function m) = n /= m+ -- notHasName _ _ = True+ -- return vs++parseInternal b (APClosure (StgInfoTable 0 0 _ _) _ _ fun _)+ = do cPtr <- contParse fun+ getSetName b >>= \x -> return $ Function x : cPtr++parseInternal b (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _)+ = getSetName b >>= \x -> return [Function x]++parseInternal _ (MVarClosure StgInfoTable{} qHead qTail qValue)+ = do cHead <- liftM mbParens $ contParse qHead+ cTail <- liftM mbParens $ contParse qTail+ cValue <- liftM mbParens $ contParse qValue+ return $ Unnamed "MVar#(" : cHead ++ [Unnamed ","] ++ cTail ++ [Unnamed ","] ++ cValue ++ [Unnamed ")"]++parseInternal _ c = return [Unnamed ("Missing pattern for " ++ show c)]++parseThunkFun :: Box -> [Box] -> [Word] -> PrintState [VisObject]+parseThunkFun b bPtrs args = do+ name <- getSetName b+ cPtrs <- mapM contParse $ reverse bPtrs+ let tPtrs = intercalate [Unnamed ","] cPtrs+ return $ if null args then+ 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)++bcoContParse :: [Box] -> PrintState [[VisObject]]+bcoContParse [] = return []+bcoContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of+ Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2+ bcoContParse $ ptf ++ bs -- Could go into infinite loop+ Just (_,c) -> do p <- parseClosure b c+ ps <- bcoContParse bs+ return $ p : ps++mutArrContParse :: [Box] -> PrintState [[VisObject]]+mutArrContParse [] = return []+mutArrContParse (b:bs) = get >>= \(_,h,_) -> case lookup b h of+ Nothing -> mutArrContParse bs+ Just (_,c) -> do p <- parseClosure b c+ ps <- mutArrContParse bs+ return $ p : ps++-- TODO: Doesn't work quite right, for example with (1,"fo")+mbParens :: [VisObject] -> [VisObject]+mbParens t@(Unnamed ('"':_):_) = t+mbParens t@(Unnamed ('(':_):_) = t+mbParens t | ' ' `objElem` t = Unnamed "(" : t ++ [Unnamed ")"]+ | otherwise = t+ where objElem c = any go+ where go (Unnamed xs) = c `elem` xs+ go (Named _ os) = any go os+ go _ = False++-- | Textual representation of Heap objects, used in the graph visualization.+showClosure :: Closure -> String+showClosure (ConsClosure StgInfoTable{} _ [dataArg] _ modl name) =+ case (modl, name) of+ k | k `elem` [ ("GHC.Word", "W#")+ , ("GHC.Word", "W8#")+ , ("GHC.Word", "W16#")+ , ("GHC.Word", "W32#")+ , ("GHC.Word", "W64#")+ ] -> show dataArg++ k | k `elem` [ ("GHC.Integer.Type", "S#")+ , ("GHC.Types", "I#")+ , ("GHC.Int", "I8#")+ , ("GHC.Int", "I16#")+ , ("GHC.Int", "I32#")+ , ("GHC.Int", "I64#")+ ] -> show $ (fromIntegral :: Word -> Int) dataArg++ ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg++ ("Types", "D#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)+ ("Types", "F#") -> printf "%0.5f" (unsafeCoerce dataArg :: Double)++ -- :m +GHC.Arr+ -- let b = array ((1,1),(3,2)) [((1,1),42),((1,2),23),((2,1),999),((2,2),1000),((3,1),1001),((3,2),1002)]+ -- b+ -- :view b+ ("GHC.Arr", "Array") -> printf "Array[%d]" dataArg++ (_,name') -> printf "%s[%d]" name' dataArg++showClosure (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS")+ = "ByteString[0,0]"++showClosure (ConsClosure (StgInfoTable 1 3 _ 0) [_] [_,start,end] _ "Data.ByteString.Internal" "PS")+ = printf "ByteString[%d,%d]" start end++showClosure (ConsClosure (StgInfoTable 2 3 _ 1) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk")+ = printf "Chunk[%d,%d]" start end++showClosure (ConsClosure StgInfoTable{} _ [] _ _ name)+ = name++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"++-- Probably should delete these from Graph+showClosure (IndClosure (StgInfoTable 1 0 _ 0) _)+ = "Ind"++showClosure (BlackholeClosure (StgInfoTable 1 0 _ 0) _)+ = "Blackhole"++-- Reversed order of ptrs+showClosure (ThunkClosure StgInfoTable{} _ _)+ = "Thunk"++showClosure (FunClosure StgInfoTable{} _ _)+ = "Fun"++showClosure (MutArrClosure StgInfoTable{} _ _ _)+ = "MutArr"++showClosure (BCOClosure (StgInfoTable 4 0 BCO 0) _ _ _ _ _ _)+ = "BCO"++showClosure (APClosure (StgInfoTable 0 0 _ _) _ _ _ _)+ = "AP"++showClosure (PAPClosure (StgInfoTable 0 0 _ _) _ _ _ _)+ = "PAP"++showClosure (MVarClosure StgInfoTable{} _ _ _)+ = "MVar#"++showClosure c = "Missing pattern for " ++ show c
+ src/GHC/Vis/Types.hs view
@@ -0,0 +1,70 @@+{- |+ Module : GHC.Vis.Types+ Copyright : (c) Dennis Felsing+ License : 3-Clause BSD-style+ Maintainer : dennis@felsin9.de++ -}+module GHC.Vis.Types (+ Signal(..),+ ViewType(..),+ State(..),+ HeapEntry,+ HeapMap,+ PrintState,+ VisObject(..)+ )+ where++import GHC.HeapView++import Graphics.XDot.Types++import qualified Control.Monad.State as MS++-- | Signals that are sent to the GUI to signal changes+data Signal = NewSignal Box String -- ^ Add a new Box to be visualized+ | UpdateSignal -- ^ Redraw+ | ClearSignal -- ^ Remove all Boxes+ | SwitchSignal -- ^ Switch to alternative view+ | ExportSignal String -- ^ Export the view to a file++-- | Visualization views+data ViewType = ListView+ | GraphView+ deriving (Enum, Eq, Bounded)++-- | The global state used for the visualizations.+data State = State+ { mousePos :: Point -- ^ Current position of the mouse, updated with every movement+ , view :: ViewType -- ^ What kind of visualization is currently running+ }++-- | An entry in a 'HeapMap', consisting of an identifier and a parsed GHC heap entry+type HeapEntry =+ ( Maybe String+ , Closure+ )+-- | A map of heap objects.+--+-- We're using a slow, eq-based list instead of a proper map because+-- StableNames' hash values aren't stable enough+type HeapMap = [(Box, HeapEntry)]++-- | The second HeapMap includes BCO pointers, needed for list visualization+type PrintState = MS.State (Integer, HeapMap, HeapMap)++-- | Simple representation of objects on the heap, so they can be arranged linearly+data VisObject = Unnamed String+ | Named String [VisObject]+ | Link String+ | Function String+ deriving Eq++instance Show VisObject where+ show (Unnamed x) = x+ show (Named x ys) = x ++ "=(" ++ show ys ++ ")"+ show (Link x) = x+ show (Function x) = x++ showList = foldr ((.) . showString . show) (showString "")