diff --git a/data/hover_collapse.svg b/data/hover_collapse.svg new file mode 100644 --- /dev/null +++ b/data/hover_collapse.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + diff --git a/data/hover_evaluate.svg b/data/hover_evaluate.svg new file mode 100644 --- /dev/null +++ b/data/hover_evaluate.svg @@ -0,0 +1,118 @@ + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + diff --git a/data/icon_collapse.svg b/data/icon_collapse.svg new file mode 100644 --- /dev/null +++ b/data/icon_collapse.svg @@ -0,0 +1,117 @@ + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + diff --git a/data/icon_evaluate.svg b/data/icon_evaluate.svg new file mode 100644 --- /dev/null +++ b/data/icon_evaluate.svg @@ -0,0 +1,104 @@ + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + diff --git a/data/main.ui b/data/main.ui --- a/data/main.ui +++ b/data/main.ui @@ -39,6 +39,11 @@ False gtk-save + + True + False + gtk-undo + True False @@ -69,6 +74,16 @@ False gtk-justify-left + + True + False + gtk-media-rewind + + + True + False + gtk-media-forward + False ghc-vis Legend @@ -103,7 +118,6 @@ gtk-cancel - False True True True @@ -118,7 +132,6 @@ gtk-save - False True True True @@ -167,7 +180,6 @@ False - False True False _File @@ -179,7 +191,6 @@ Clear (:clear, c) - False True False image3 @@ -189,7 +200,6 @@ Export (:export) - False True False image2 @@ -198,7 +208,6 @@ - False True False @@ -206,7 +215,6 @@ gtk-quit - False True False True @@ -219,7 +227,6 @@ - False True False _View @@ -229,9 +236,17 @@ True False + + Restore collapsed nodes (:restore, C) + True + False + image10 + False + + + Switch (:switch, v) - False True False image4 @@ -241,7 +256,6 @@ Update (:update, u) - False True False image5 @@ -253,8 +267,39 @@ + + True + False + _History + True + + + True + False + + + Back (:timeback, ,) + True + False + image8 + False + + + + + Forward (:timeforward, .) + True + False + image9 + False + + + + + + + - False True False _Help @@ -266,7 +311,6 @@ Legend - False True False image7 @@ -276,7 +320,6 @@ gtk-about - False True False True diff --git a/data/welcome.svg b/data/welcome.svg --- a/data/welcome.svg +++ b/data/welcome.svg @@ -8,1480 +8,1314 @@ xmlns:svg="http://www.w3.org/2000/svg" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink" - xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd" - xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape" - width="919.96094" - height="889.92102" - id="svg3450" - version="1.1" - inkscape:version="0.48.3.1 r9886" - sodipodi:docname="welcome.svg"> - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - image/svg+xml - - - - - - - ghc-vis - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Type :view x in GHCito visualize expression x - - - - - - - - - : - - - - - - S# 1 - - - - - - : - - - - - - S# 1 - - - - - - Thunk - - - - - - S# 0 - - - - - - - - - - [1,1..] - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + version="1.1" + width="899.96094" + height="768.12683" + viewBox="0 0 719.96875 614.50146" + id="svg2"> + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + ghc-vis + Type :view x in GHCito visualize expression x + + + + + + + + + + + + : + + + + + + + + + S# + + + 1 + + + + + + + + + + + + : + + + + + + + + + S# + + + 1 + + + + + + + + + + + + Thunk + + + + + + + + + S# + + + 0 + + + + + + + + + + [1,1..] + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/ghc-vis.cabal b/ghc-vis.cabal --- a/ghc-vis.cabal +++ b/ghc-vis.cabal @@ -1,14 +1,14 @@ name: ghc-vis -version: 0.6.1.1 +version: 0.7 license: BSD3 license-file: LICENSE category: GHC, Debug, Development cabal-version: >= 1.10 build-type: Custom -author: Dennis Felsing +author: Dennis Felsing, Joachim Breitner maintainer: Dennis Felsing homepage: http://felsin9.de/nnis/ghc-vis -copyright: Dennis Felsing 2012 +copyright: Dennis Felsing 2012-2013 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 @@ -20,8 +20,8 @@ how it can be used with GHCi's debugger: -tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1 -data-files: ghci data/main.ui data/welcome.svg data/legend_graph.svg data/legend_list.svg +tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3 +data-files: ghci data/main.ui data/welcome.svg data/legend_graph.svg data/legend_list.svg data/icon_collapse.svg data/icon_evaluate.svg data/hover_collapse.svg data/hover_evaluate.svg Extra-source-files: nonghci-test.hs flag graph @@ -32,13 +32,13 @@ Default: True Description: "Full ghc-vis window: decorations, buttons, legend" -flag sdl - Default: False - Description: "SDL window" +--flag sdl +-- Default: False +-- Description: "SDL window" Library - Exposed-modules: GHC.Vis - Other-modules: GHC.Vis.Internal GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common Paths_ghc_vis + Exposed-modules: GHC.Vis GHC.Vis.Internal + Other-modules: GHC.Vis.Types GHC.Vis.View.List GHC.Vis.View.Common Paths_ghc_vis Default-Language: Haskell2010 Build-depends: base >= 4.5 && < 4.7, mtl >= 2.0 && < 2.2, @@ -48,8 +48,9 @@ transformers == 0.3.*, containers >= 0.4 && < 0.6, gtk == 0.12.*, + svgcairo == 0.12.*, cairo == 0.12.*, - ghc-heap-view == 0.4.* + ghc-heap-view == 0.5.* Hs-source-dirs: src/ Ghc-options: -Wall -fno-warn-unused-do-bind @@ -60,12 +61,11 @@ Cpp-options: -DGRAPH_VIEW if flag(full) - Build-depends: svgcairo >= 0.12 Cpp-options: -DFULL_WINDOW - if flag(sdl) - Build-depends: SDL == 0.6.* - Cpp-options: -DSDL_WINDOW + --if flag(sdl) + -- Build-depends: SDL == 0.6.* + -- Cpp-options: -DSDL_WINDOW source-repository head type: git diff --git a/ghci b/ghci --- a/ghci +++ b/ghci @@ -6,6 +6,9 @@ :def switch \_ -> return $ "GHC.Vis.switch" :def update \_ -> return $ "GHC.Vis.update" :def clear \_ -> return $ "GHC.Vis.clear" +:def restore \_ -> return $ "GHC.Vis.restore" +:def timeBack \_ -> return $ "GHC.Vis.history (+1)" +:def timeForward \_ -> return $ "GHC.Vis.history (\\x -> x - 1)" :def export \x -> return $ "GHC.Vis.export " ++ show x -- Evaluate one step and update values in ghc-vis diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs --- a/src/GHC/Vis.hs +++ b/src/GHC/Vis.hs @@ -44,6 +44,8 @@ switch, update, clear, + restore, + history, export ) where @@ -66,6 +68,8 @@ import Data.Char import Data.IORef +import qualified Data.IntMap as M + import System.Timeout import System.Mem @@ -81,7 +85,7 @@ import qualified GHC.Vis.View.Graph as Graph #endif -import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo hiding (restore) #ifdef FULL_WINDOW import Graphics.Rendering.Cairo.SVG @@ -176,6 +180,14 @@ clear :: IO () clear = put ClearSignal +-- | Reset the hidden boxes +restore :: IO () +restore = put RestoreSignal + +-- | Change position in history +history :: (Int -> Int) -> IO () +history = put . HistorySignal + -- | Export the current visualization view to a file, format depends on the -- file ending. Currently supported: svg, png, pdf, ps export :: String -> IO () @@ -396,9 +408,18 @@ when (E.eventKeyName e `elem` ["c"]) $ put ClearSignal + when (E.eventKeyName e `elem` ["C"]) $ + put RestoreSignal + when (E.eventKeyName e `elem` ["u"]) $ put UpdateSignal + when (E.eventKeyName e `elem` ["comma", "bracketleft"]) $ + put $ HistorySignal (+1) + + when (E.eventKeyName e `elem` ["period", "bracketright"]) $ + put $ HistorySignal (\x -> x - 1) + widgetQueueDraw canvas return True @@ -445,7 +466,7 @@ return ()) boxes <- readMVar visBoxes - performGC -- TODO: Else Blackholes appear. Do we want this? + performGC -- Else Blackholes appear. Do we want this? -- Blackholes stop our current thread and only resume after -- they have been replaced with their result, thereby leading -- to an additional element in the HeapMap we don't want. @@ -463,7 +484,7 @@ #ifdef GRAPH_VIEW where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi then modifyIORef visState (\s -> s {T.view = succN (T.view s), zoomRatio = 1, position = (0, 0)}) - else putStrLn "Cannot switch view: Graphviz not installed" + else putStrLn "Cannot switch view: The Graphviz binary (dot) is not installed" succN GraphView = ListView succN ListView = GraphView @@ -488,27 +509,46 @@ timeout signalTimeout (putMVar visSignal UpdateSignal) react canvas legendCanvas) Just signal -> do - case signal of - NewSignal x n -> modifyMVar_ visBoxes ( - \y -> return $ if (x,n) `elem` y then y else y ++ [(x,n)]) - ClearSignal -> modifyMVar_ visBoxes (\_ -> return []) - UpdateSignal -> return () - SwitchSignal -> doSwitch - ExportSignal d f -> catch (runCorrect exportView >>= \e -> e d f) - (\e -> do let err = show (e :: IOException) - hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err - return ()) + doUpdate <- case signal of + NewSignal x n -> do + modifyMVar_ visBoxes (\y -> return $ if ([n], x) `elem` y then y else y ++ [([n], x)]) + return True + ClearSignal -> do + modifyMVar_ visBoxes $ const $ return [] + modifyMVar_ visHidden $ const $ return [] + modifyMVar_ visHeapHistory $ const $ return (0, [(HeapGraph M.empty, [])]) + return False + RestoreSignal -> do + modifyMVar_ visHidden $ const $ return [] + return False + RedrawSignal -> return False + UpdateSignal -> return True + SwitchSignal -> doSwitch >> return False + HistorySignal f -> do + modifyMVar_ visHeapHistory (\(i,xs) -> return (max 0 (min (length xs - 1) (f i)), xs)) + return False + ExportSignal d f -> do + catch (runCorrect exportView >>= \e -> e d f) + (\e -> do let err = show (e :: IOException) + hPutStrLn stderr $ "Couldn't export to file \"" ++ f ++ "\": " ++ err + return ()) + return False boxes <- readMVar visBoxes - performGC -- TODO: Else Blackholes appear. Do we want this? - -- Blackholes stop our current thread and only resume after - -- they have been replaced with their result, thereby leading - -- to an additional element in the HeapMap we don't want. - -- Example for bad behaviour that would happen then: - -- λ> let xs = [1..42] :: [Int] - -- λ> let x = 17 :: Int - -- λ> let ys = [ y | y <- xs, y >= x ] + when doUpdate $ do + performGC -- Else Blackholes appear. Do we want this? + -- Blackholes stop our current thread and only resume after + -- they have been replaced with their result, thereby leading + -- to an additional element in the HeapMap we don't want. + -- Example for bad behaviour that would happen then: + -- λ> let xs = [1..42] :: [Int] + -- λ> let x = 17 :: Int + -- λ> let ys = [ y | y <- xs, y >= x ] + + x <- multiBuildHeapGraph 10 boxes + modifyMVar_ visHeapHistory (\(i,xs) -> return (i,x:xs)) + runCorrect updateObjects >>= \f -> f boxes postGUISync $ widgetQueueDraw canvas @@ -518,7 +558,7 @@ #ifdef GRAPH_VIEW where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi then modifyIORef visState (\s -> s {T.view = succN (T.view s), zoomRatio = 1, position = (0, 0)}) - else putStrLn "Cannot switch view: Graphviz not installed" + else putStrLn "Cannot switch view: The Graphviz binary (dot) is not installed" succN GraphView = ListView succN ListView = GraphView @@ -533,8 +573,6 @@ zoomImage :: WidgetClass w1 => w1 -> State -> Double -> T.Point -> IO T.Point zoomImage _canvas s newZoomRatio _mousePos@(_x', _y') = do - -- TODO: Mouse must stay at same spot - --E.Rectangle _ _ rw' rh' <- widgetGetAllocation canvas --let (rw, rh) = (fromIntegral rw', fromIntegral rh') --let (x,y) = (x' - rw / 2, y' - rh / 2) @@ -550,9 +588,8 @@ visMainThread = do initGUI - mainUIFile <- My.getDataFileName "data/main.ui" builder <- builderNew - builderAddFromFile builder mainUIFile + builderAddFromFile builder =<< My.getDataFileName "data/main.ui" let get :: forall cls . GObjectClass cls => (GObject -> cls) @@ -581,13 +618,16 @@ onDelete aboutDialog $ const $ widgetHide aboutDialog >> return True onDelete legendDialog $ const $ widgetHide legendDialog >> return True - get castToMenuItem "clear" >>= \item -> onActivateLeaf item clear - get castToMenuItem "switch" >>= \item -> onActivateLeaf item switch - get castToMenuItem "update" >>= \item -> onActivateLeaf item update - get castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog - get castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window - get castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog - get castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog + get castToMenuItem "clear" >>= \item -> onActivateLeaf item clear + get castToMenuItem "switch" >>= \item -> onActivateLeaf item switch + get castToMenuItem "restore" >>= \item -> onActivateLeaf item restore + get castToMenuItem "update" >>= \item -> onActivateLeaf item update + get castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog + get castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window + get castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog + get castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog + get castToMenuItem "timeback" >>= \item -> onActivateLeaf item $ history (+1) + get castToMenuItem "timeforward" >>= \item -> onActivateLeaf item $ history (\x -> x - 1) widgetModifyBg canvas StateNormal backgroundColor widgetModifyBg legendCanvas StateNormal backgroundColor 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 CPP, MagicHash, DeriveDataTypeable, NoMonomorphismRestriction, RankNTypes #-} +{-# LANGUAGE CPP, MagicHash, DeriveDataTypeable, NoMonomorphismRestriction, RankNTypes, RecordWildCards #-} {- | Module : GHC.Vis.Internal @@ -8,11 +8,8 @@ -} module GHC.Vis.Internal ( - walkHeap, - parseBoxes, - parseBoxesHeap, - pointersToFollow2, - showClosure + parseClosure, + showClosureFields ) where @@ -21,96 +18,80 @@ #endif import GHC.Vis.Types -import GHC.HeapView hiding (name, pkg, modl, fun, arrWords) +import GHC.HeapView hiding (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 qualified Data.IntMap as M import Text.Printf import Unsafe.Coerce -import Control.Monad.Trans.Maybe - import System.IO.Unsafe --- | Maximum depth which walkHeap recurses to. Prevents users from evaluating --- data structures which are too big and would take very long to visualize. -maxHeapWalkDepth :: Int -maxHeapWalkDepth = 100 - --- | Walk the heap for a list of objects to be visualized and their --- corresponding names. -parseBoxes :: [(Box, String)] -> IO [[VisObject]] -parseBoxes bs = do - r <- generalParseBoxes evalState bs - case r of - Just x -> return x - _ -> do - putStrLn "Failure, trying again" - parseBoxes bs +-- TODO: Remove +instance Eq Box where + a == b = unsafePerformIO $ areBoxesEqual a b --- | 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]], PState) -parseBoxesHeap bs = do - r <- generalParseBoxes runState bs - case r of - (Just x, y) -> return (x,y) - _ -> parseBoxesHeap bs +-- | Parse a closure to a list of VisObjects +parseClosure :: HeapGraphIndex -> PrintState [VisObject] +parseClosure i = do + o <- correctObject i + case o of + Link n -> return [Link n] -- Don't build infinite heaps + _ -> do HeapGraph m <- gets heapGraph + l <- parseInternal i $ hgeClosure $ m M.! i + return $ insertObjects o l -generalParseBoxes :: - (PrintState (Maybe [[VisObject]]) -> PState -> b) - -> [(Box, String)] -> IO b -generalParseBoxes f bs = do - h <- walkHeapSimply bs - h2 <- walkHeapWithBCO bs - return $ f (g bs) $ PState 0 0 0 h h2 - where g bs' = runMaybeT $ go bs' - go ((b',_):b's) = do h <- lift $ gets heapMap' - (_,c) <- lookupT b' h - r <- parseClosure b' c - rs <- go b's - return $ simplify r : rs - go [] = return [] +correctObject :: HeapGraphIndex -> PrintState VisObject +correctObject i = do + name <- getName i + bindings <- gets bindings -lookupT :: Eq a => a -> [(a,b)] -> MaybeT PrintState b -lookupT b' h = MaybeT $ return $ lookup b' h + if null name + then if i `elem` bindings then + (do name' <- setName i + return $ Named name' []) + else return $ Unnamed "" + else return $ Link name --- 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 +setName :: HeapGraphIndex -> PrintState String +setName i = do + n <- getName i + if null n + then do + s@(PState ti fi xi _ (HeapGraph m)) <- get + let Just hge@(HeapGraphEntry{hgeClosure = c}) = M.lookup i m + let (name,newState) = case bindingLetter c of + 't' -> ('t' : show ti, s{tCounter' = ti + 1}) + 'f' -> ('f' : show fi, s{fCounter' = fi + 1}) + 'x' -> ('x' : show xi, s{xCounter' = xi + 1}) + _ -> error "Invalid letter" -parseClosure :: Box -> Closure -> MaybeT 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 + let m' = M.insert i (hge{hgeData = name}) m + put $ newState{heapGraph = HeapGraph m'} + return name + else return n -correctObject :: Box -> MaybeT PrintState VisObject -correctObject box = do - r <- lift $ countReferences box - n <- getName box + where + bindingLetter c = case c of + ThunkClosure {..} -> 't' + SelectorClosure {..} -> 't' + APClosure {..} -> 't' + PAPClosure {..} -> 'f' + BCOClosure {..} -> 't' + FunClosure {..} -> 'f' + _ -> 'x' - case n of - Just name -> return $ Link name - Nothing -> if r > 1 then - (do setName box - mbName <- getName box - name <- MaybeT $ return mbName - return $ Named name []) - else return $ Unnamed "" +getName :: HeapGraphIndex -> PrintState String +getName i = do + HeapGraph m <- gets heapGraph + return $ hgeData $ m M.! i insertObjects :: VisObject -> [VisObject] -> [VisObject] insertObjects _ xs@(Function _ : _) = xs @@ -120,144 +101,7 @@ 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 maxHeapWalkDepth p2f) l p - step depth p2f l b = case lookup b l of - Just _ -> return l - Nothing -> do - c' <- getBoxedClosureData b - p <- p2f c' - if depth == 0 && not (null p) - then do - putStrLn "Warning: Maximum data structure depth reached, output is truncated" - return $ insert (b, (Nothing, maxDepthClosure)) l - else foldM (step (depth - 1) p2f) (insert (b, (Nothing, c')) l) p - dummy = (asBox (1 :: Integer), - (Nothing, ConsClosure (StgInfoTable 0 0 CONSTR 0) (map fst bs) [] "" "" "")) - maxDepthClosure = ConsClosure (StgInfoTable 0 0 CONSTR 0) [] [] "" "" "..." - --- 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{} = return [] - -pointersToFollow (MutArrClosure _ _ _ bPtrs) = - do cPtrs <- mapM getBoxedClosureData bPtrs - return $ fix $ zip bPtrs cPtrs - where fix ((_,ConsClosure _ _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs - fix ((_,ConsClosure _ _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs - fix ((_,ConsClosure _ _ _ _ "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 _ _ _ bPtrs) = - do cPtrs <- mapM getBoxedClosureData bPtrs - return $ fix $ zip bPtrs cPtrs - where fix ((_,ConsClosure _ _ _ _ "ByteCodeInstr" "BreakInfo"):_:_:xs) = fix xs - fix ((_,ConsClosure _ _ _ _ "ByteCodeInstr" "BreakInfo"):_:xs) = fix xs - fix ((_,ConsClosure _ _ _ _ "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 -> 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 -> MaybeT PrintState () -setName b = do PState ti fi bi h h2 <- lift get - (_,c) <- lookupT b h2 - let (n, ti',fi',bi') = case c of - ThunkClosure{} -> ('t' : show ti, ti+1, fi, bi) - APClosure{} -> ('t' : show ti, ti+1, fi, bi) - FunClosure{} -> ('f' : show fi, ti, fi+1, bi) - PAPClosure{} -> ('f' : show fi, ti, fi+1, bi) - _ -> ('b' : show bi, ti, fi, bi+1) - set (Nothing, closure) = (Just n, closure) - set _ = error "unexpected pattern" - h' <- MaybeT $ return $ adjust set b h - h2' <- MaybeT $ return $ adjust set b h2 - lift $ put $ PState ti' fi' bi' h' h2' - -setVisited :: Box -> MaybeT PrintState () -setVisited b = do PState ti fi bi h h2 <- lift get - let set (Nothing, closure) = (Just "visited", closure) - set _ = error "unexpected pattern" - h2' <- MaybeT $ return $ adjust set b h2 - lift $ put $ PState ti fi bi h h2' - -getName :: Box -> MaybeT PrintState (Maybe String) -getName b = do h <- lift $ gets heapMap' - (name,_) <- lookupT b h - return name - -getSetName :: Box -> MaybeT PrintState String -getSetName b = do mn <- getName b - case mn of - Nothing -> do setName b - name <- getName b - MaybeT $ return name - Just name -> return name - --- How often is a box referenced in the entire heap map -countReferences :: Box -> PrintState Int -countReferences b = do - h <- gets heapMap' - return $ sum $ map countR h - where countR (_,(_,c)) = length $ filter (== b) $ allPtrs c - -parseInternal :: Box -> Closure -> MaybeT PrintState [VisObject] +parseInternal :: HeapGraphIndex -> GenClosure (Maybe HeapGraphIndex) -> PrintState [VisObject] parseInternal _ (ConsClosure _ [] [dataArg] _pkg modl name) = return [Unnamed $ case (modl, name) of k | k `elem` [ ("GHC.Word", "W#") @@ -284,8 +128,6 @@ _ -> printf "%s %d" (infixFix name) dataArg ] --- Empty ByteStrings point to a nullForeignPtr, evaluating it leads to an --- Prelude.undefined exception parseInternal _ (ConsClosure (StgInfoTable 1 3 _ _) _ [_,0,0] _ "Data.ByteString.Internal" "PS") = return [Unnamed "ByteString 0 0"] @@ -332,15 +174,15 @@ -- Reversed order of ptrs parseInternal b (ThunkClosure _ bPtrs args) = do - name <- getSetName b + name <- setName b cPtrs <- mapM contParse $ reverse bPtrs let tPtrs = intercalate [Unnamed ","] cPtrs sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"] sArgs = Unnamed $ if null args then "" else show args return $ Thunk (infixFix name) : sPtrs ++ [sArgs] -parseInternal b (FunClosure _ bPtrs args) = do - name <- getSetName b +parseInternal i (FunClosure _ bPtrs args) = do + name <- setName i cPtrs <- mapM contParse $ reverse bPtrs let tPtrs = intercalate [Unnamed ","] cPtrs sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"] @@ -349,7 +191,8 @@ -- bPtrs here can currently point to Nothing, because else we might get infinite heaps parseInternal _ (MutArrClosure _ _ _ bPtrs) - = do cPtrs <- mutArrContParse bPtrs + -- = do cPtrs <- mutArrContParse2 bPtrs + = do cPtrs <- mapM contParse bPtrs let tPtrs = intercalate [Unnamed ","] cPtrs return $ if null tPtrs then [Unnamed ""] else Unnamed "(" : tPtrs ++ [Unnamed ")"] @@ -357,45 +200,30 @@ = do c <- contParse b return $ Unnamed "MutVar " : c -parseInternal b (BCOClosure _ _ _ bPtr _ _ _) - = do cPtrs <- bcoContParse [bPtr] +parseInternal _ (BCOClosure _ _ _ bPtr _ _ _) + -- = do cPtrs <- bcoContParse2 [bPtr] + = do cPtrs <- mapM contParse [bPtr] let tPtrs = intercalate [Unnamed ","] cPtrs - r <- lift $ countReferences b - return $ if null tPtrs then if r > 1 then [Unnamed "BCO"] else [Unnamed ""] else (if r > 1 then Unnamed "BCO(" else 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 + return $ Unnamed "BCO" : tPtrs -parseInternal b (APClosure _ _ _ fun pl) = do - name <- getSetName b +parseInternal i (APClosure _ _ _ fun pl) = do + name <- setName i fPtr <- contParse fun pPtrs <- mapM contParse $ reverse pl let tPtrs = intercalate [Unnamed ","] pPtrs sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "[" : tPtrs ++ [Unnamed "]"] return $ Thunk (infixFix name) : fPtr ++ sPtrs -parseInternal b (PAPClosure _ _ _ fun pl) = do - name <- getSetName b +parseInternal i (PAPClosure _ _ _ fun pl) = do + name <- setName i fPtr <- contParse fun pPtrs <- mapM contParse $ reverse pl let tPtrs = intercalate [Unnamed ","] pPtrs sPtrs = if null tPtrs then [Unnamed ""] else Unnamed "[" : tPtrs ++ [Unnamed "]"] return $ Function (infixFix name) : fPtr ++ sPtrs -parseInternal b (APStackClosure _ fun pl) = do - name <- getSetName b +parseInternal i (APStackClosure _ fun pl) = do + name <- setName i fPtr <- contParse fun pPtrs <- mapM contParse $ reverse pl let tPtrs = intercalate [Unnamed ","] pPtrs @@ -408,10 +236,9 @@ cValue <- liftM mbParens $ contParse qValue return $ Unnamed "MVar#(" : cHead ++ [Unnamed ","] ++ cTail ++ [Unnamed ","] ++ cValue ++ [Unnamed ")"] -contParse :: Box -> MaybeT PrintState [VisObject] -contParse b = do h <- lift $ gets heapMap - (_,c) <- lookupT b h - parseClosure b c +contParse :: Maybe HeapGraphIndex -> PrintState [VisObject] +contParse Nothing = return [] +contParse (Just i) = parseClosure i -- It turned out that bcoContParse actually does go into an infinite loop, for -- example for this: @@ -420,28 +247,28 @@ -- :view foldr' -- We fix this by giving visited closures a dummy name, so we recognize when we -- get into a loop. -bcoContParse :: [Box] -> MaybeT PrintState [[VisObject]] -bcoContParse [] = return [] -bcoContParse (b:bs) = gets heapMap >>= \h -> case lookup b h of - Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2 - r <- lift $ countReferences b - n <- getName b - case n of - Just _ -> bcoContParse bs - Nothing -> do - when (r > 1) $ setVisited b - bcoContParse $ ptf ++ bs - Just (_,c) -> do p <- parseClosure b c - ps <- bcoContParse bs - return $ p : ps +--bcoContParse :: [Box] -> MaybeT PrintState [[VisObject]] +--bcoContParse [] = return [] +--bcoContParse (b:bs) = gets heapMap >>= \h -> case lookup b h of +-- Nothing -> do let ptf = unsafePerformIO $ getBoxedClosureData b >>= pointersToFollow2 +-- r <- lift $ countReferences b +-- n <- getName b +-- case n of +-- Just _ -> bcoContParse bs +-- Nothing -> do +-- when (r > 1) $ setVisited b +-- bcoContParse $ ptf ++ bs +-- Just (_,c) -> do p <- parseClosure b c +-- ps <- bcoContParse bs +-- return $ p : ps -mutArrContParse :: [Box] -> MaybeT PrintState [[VisObject]] -mutArrContParse [] = return [] -mutArrContParse (b:bs) = gets heapMap >>= \h -> case lookup b h of - Nothing -> mutArrContParse bs - Just (_,c) -> do p <- parseClosure b c - ps <- mutArrContParse bs - return $ p : ps +--mutArrContParse :: [Box] -> MaybeT PrintState [[VisObject]] +--mutArrContParse [] = return [] +--mutArrContParse (b:bs) = gets heapMap >>= \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] @@ -463,16 +290,19 @@ -- go (Named _ os) = any go os -- go _ = False +--showClosure :: Closure -> String +--showClosure = unwords . showClosureFields + -- | Textual representation of Heap objects, used in the graph visualization. -showClosure :: Closure -> String -showClosure (ConsClosure _ _ [dataArg] _ modl name) = +showClosureFields :: GenClosure t -> [String] +showClosureFields (ConsClosure _ _ [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#") - ] -> name ++ " " ++ show dataArg + ] -> [name, show dataArg] k | k `elem` [ ("GHC.Integer.Type", "S#") , ("GHC.Types", "I#") @@ -480,80 +310,80 @@ , ("GHC.Int", "I16#") , ("GHC.Int", "I32#") , ("GHC.Int", "I64#") - ] -> name ++ " " ++ show ((fromIntegral :: Word -> Int) dataArg) + ] -> [name, show ((fromIntegral :: Word -> Int) dataArg)] - ("GHC.Types", "C#") -> show . chr $ fromIntegral dataArg + ("GHC.Types", "C#") -> ["C#", [chr $ fromIntegral dataArg]] - ("GHC.Types", "D#") -> printf "D# %0.5f" (unsafeCoerce dataArg :: Double) - ("GHC.Types", "F#") -> printf "F# %0.5f" (unsafeCoerce dataArg :: Double) + ("GHC.Types", "D#") -> ["D#", printf "%0.5f" (unsafeCoerce dataArg :: Double)] + ("GHC.Types", "F#") -> ["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 - _ -> printf "%s %d" name dataArg + _ -> [name, show dataArg] -showClosure (ConsClosure (StgInfoTable 1 3 _ 0) _ [_,0,0] _ "Data.ByteString.Internal" "PS") - = "ByteString 0 0" +showClosureFields (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 +showClosureFields (ConsClosure (StgInfoTable 1 3 _ 0) [_] [_,start,end] _ "Data.ByteString.Internal" "PS") + = ["ByteString",printf "%d" start,printf "%d" end] -showClosure (ConsClosure (StgInfoTable 2 3 _ 1) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") - = printf "Chunk %d %d" start end +showClosureFields (ConsClosure (StgInfoTable 2 3 _ 1) [_,_] [_,start,end] _ "Data.ByteString.Lazy.Internal" "Chunk") + = ["Chunk",printf "%d" start,printf "%d" end] -showClosure (ConsClosure _ _ dArgs _ _ name) - = unwords $ name : map show dArgs +showClosureFields (ConsClosure _ _ dArgs _ _ name) + = name : map show dArgs -- Reversed order of ptrs -showClosure ThunkClosure{} - = "Thunk" +showClosureFields ThunkClosure{} + = ["Thunk"] -showClosure SelectorClosure{} - = "Selector" +showClosureFields SelectorClosure{} + = ["Selector"] -- Probably should delete these from Graph -showClosure IndClosure{} - = "Ind" +showClosureFields IndClosure{} + = ["Ind"] -showClosure BlackholeClosure{} - = "Blackhole" +showClosureFields BlackholeClosure{} + = ["Blackhole"] -showClosure APClosure{} - = "AP" +showClosureFields APClosure{} + = ["AP"] -showClosure PAPClosure{} - = "PAP" +showClosureFields PAPClosure{} + = ["PAP"] -showClosure APStackClosure{} - = "APStack" +showClosureFields APStackClosure{} + = ["APStack"] -showClosure BCOClosure{} - = "BCO" +showClosureFields BCOClosure{} + = ["BCO"] -showClosure (ArrWordsClosure _ _ arrWords) - = intercalate ",\n" $ map (printf "0x%x") arrWords +showClosureFields (ArrWordsClosure _ _ arrWords) + = map (printf "0x%x") arrWords -showClosure MutArrClosure{} - = "MutArr" +showClosureFields MutArrClosure{} + = ["MutArr"] -showClosure MutVarClosure{} - = "MutVar" +showClosureFields MutVarClosure{} + = ["MutVar"] -showClosure MVarClosure{} - = "MVar#" +showClosureFields MVarClosure{} + = ["MVar#"] -showClosure FunClosure{} - = "Fun" +showClosureFields FunClosure{} + = ["Fun"] -showClosure BlockingQueueClosure{} - = "BlockingQueue" +showClosureFields BlockingQueueClosure{} + = ["BlockingQueue"] -showClosure (OtherClosure (StgInfoTable _ _ cTipe _) _ _) - = show cTipe +showClosureFields (OtherClosure (StgInfoTable _ _ cTipe _) _ _) + = [show cTipe] -showClosure (UnsupportedClosure (StgInfoTable _ _ cTipe _)) - = show cTipe +showClosureFields (UnsupportedClosure (StgInfoTable _ _ cTipe _)) + = [show cTipe] --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 @@ -13,8 +13,8 @@ View(..), ViewType(..), State(..), - HeapEntry, - HeapMap, + Identifier, + NamedBox, PState(..), PrintState, VisObject(..) @@ -36,9 +36,12 @@ -- | Signals that are sent to the GUI to signal changes data Signal = NewSignal Box String -- ^ Add a new Box to be visualized - | UpdateSignal -- ^ Redraw + | UpdateSignal -- ^ Update the view + | RedrawSignal -- ^ Redraw | ClearSignal -- ^ Remove all Boxes + | RestoreSignal -- ^ Reset all hidden boxes | SwitchSignal -- ^ Switch to alternative view + | HistorySignal (Int -> Int) -- ^ Change position in history | ExportSignal DrawFunction String -- ^ Export the view to a file -- | All functions a view has to provide @@ -46,7 +49,7 @@ { redraw :: WidgetClass w => w -> IO () , click :: IO () , move :: WidgetClass w => w -> IO () - , updateObjects :: [(Box, String)] -> IO () + , updateObjects :: [NamedBox] -> IO () , exportView :: DrawFunction -> String -> IO () } @@ -65,23 +68,19 @@ , wasDragged :: Bool -- ^ Whether the mouse was actually dragged } --- | 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)] +-- | Identifier of a closure +type Identifier = [String] --- | The second HeapMap includes BCO pointers, needed for list visualization +-- | A box and its identifier +type NamedBox = (Identifier, Box) + +-- | Internal state of the list view generator data PState = PState - { tCounter :: Integer - , fCounter :: Integer - , bCounter :: Integer - , heapMap :: HeapMap - , heapMap' :: HeapMap + { tCounter' :: Integer + , fCounter' :: Integer + , xCounter' :: Integer + , bindings :: [HeapGraphIndex] + , heapGraph :: HeapGraph String } -- | The state of a printing operation diff --git a/src/GHC/Vis/View/Common.hs b/src/GHC/Vis/View/Common.hs --- a/src/GHC/Vis/View/Common.hs +++ b/src/GHC/Vis/View/Common.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables, RecordWildCards #-} {- | Module : GHC.Vis.View.Common Copyright : (c) Dennis Felsing @@ -11,6 +11,12 @@ visRunning, visState, visBoxes, + visHidden, + visHeapHistory, + getHeapGraph, + inHistoryMode, + parseBoxes, + parseBoxesHeap, evaluate ) where @@ -23,8 +29,15 @@ import Control.DeepSeq import Control.Exception hiding (evaluate) +import Control.Monad.State hiding (State, fix) + +import qualified Data.IntMap as M + import Data.IORef +import Data.Maybe (catMaybes) +import Data.List + import System.IO.Unsafe import GHC.Vis.Internal @@ -44,29 +57,75 @@ visState = unsafePerformIO $ newIORef $ State (0, 0) ListView 1 (0, 0) False False -- | All the visualized boxes -visBoxes :: MVar [(Box, String)] -visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [(Box, String)])) +visBoxes :: MVar [NamedBox] +visBoxes = unsafePerformIO (newMVar [] :: IO (MVar [NamedBox])) +-- | Hidden boxes +visHidden :: MVar [Box] +visHidden = unsafePerformIO (newMVar [] :: IO (MVar [Box])) + +-- | All heap graphs since the last clear command +visHeapHistory :: MVar (Int, [(HeapGraph Identifier, [(Identifier, HeapGraphIndex)])]) +visHeapHistory = unsafePerformIO (newMVar (0, [(HeapGraph M.empty, [])]) :: IO (MVar (Int, [(HeapGraph Identifier, [(Identifier, HeapGraphIndex)])]))) + +-- | Get the currently selected heap graph +getHeapGraph :: IO (HeapGraph Identifier, [(Identifier, HeapGraphIndex)]) +getHeapGraph = do + (pos, xs) <- readMVar visHeapHistory + return $ xs !! pos + +-- | Whether we're currently looking at an older heap graph or the most recent one +inHistoryMode :: IO Bool +inHistoryMode = liftM ((> 0) . fst) $ readMVar visHeapHistory + -- | Evaluate an object identified by a String. evaluate :: String -> IO () -evaluate identifier = do (_,hm) <- printAll - (show (map go hm) `deepseq` return ()) `catch` +evaluate identifier = do (_,HeapGraph m) <- printAll + (show (M.map go m) `deepseq` return ()) `catch` \(e :: SomeException) -> putStrLn $ "Caught exception while evaluating: " ++ show e - where go (Box a,(Just n, y)) | n == identifier = seq a (Just n, y) - | otherwise = (Just n, y) - go (_,(x,y)) = (x,y) + where go hge@(HeapGraphEntry (Box a) _ _ n) | n == identifier = seq a hge + | otherwise = hge ---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" +-- | Walk the heap for a list of objects to be visualized and their +-- corresponding names. +parseBoxes :: IO [[VisObject]] +parseBoxes = generalParseBoxes evalState -printAll :: IO (String, HeapMap) +-- | 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 :: IO ([[VisObject]], PState) +parseBoxesHeap = generalParseBoxes runState + +--generalParseBoxes :: +-- (PrintState (Maybe [[VisObject]]) -> PState -> b) +-- -> [NamedBox] -> IO b +generalParseBoxes :: (PrintState [[VisObject]] -> PState -> b) -> IO b +generalParseBoxes f = do + --(hg, starts) <- multiBuildHeapGraph 100 $ map (\(_,x) -> ("",x)) bs + (hg@(HeapGraph m), starts) <- getHeapGraph + let bindings = boundMultipleTimes hg $ map snd starts + let g i = do + r <- parseClosure i + return $ simplify r + return $ f (mapM (g . snd) starts) $ PState 1 1 1 bindings $ HeapGraph $ M.map (\hge -> hge{hgeData = ""}) m + +-- | In the given HeapMap, list all indices that are used more than once. The +-- second parameter adds external references, commonly @[heapGraphRoot]@. +boundMultipleTimes :: HeapGraph a -> [HeapGraphIndex] -> [HeapGraphIndex] +boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $ + roots ++ concatMap (catMaybes . allPtrs . hgeClosure) (M.elems m) + +-- 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 + +printAll :: IO (String, HeapGraph String) printAll = do - bs <- readMVar visBoxes - (t, PState{heapMap = h}) <- parseBoxesHeap bs + (t, PState{heapGraph = h}) <- parseBoxesHeap return (show t, h) diff --git a/src/GHC/Vis/View/Graph.hs b/src/GHC/Vis/View/Graph.hs --- a/src/GHC/Vis/View/Graph.hs +++ b/src/GHC/Vis/View/Graph.hs @@ -27,6 +27,7 @@ import Control.Monad import Control.Exception +import Data.Maybe import Data.IORef import System.IO.Unsafe @@ -39,17 +40,44 @@ import Graphics.XDot.Viewer import Graphics.XDot.Types hiding (size, w, h) +import Graphics.Rendering.Cairo.SVG +import Paths_ghc_vis as My + +hoverIconWidth :: Double +hoverIconWidth = 35 + +hoverIconHeight :: Double +hoverIconHeight = 17.5 + +hoverIconSpace :: Double +hoverIconSpace = 5 + +data Icon = EvaluateIcon + | CollapseIcon + deriving (Show, Eq) + data State = State { boxes :: [Box] , operations :: [(Object Int, Operation)] - , totalSize :: (Double, Double, Double, Double) - , bounds :: [(Object Int, (Double, Double, Double, Double))] + , totalSize :: Rectangle + , bounds :: [(Object Int, Rectangle)] + , hoverIconBounds :: [(Object Int, [(Icon, Rectangle)])] , hover :: Object Int + , iconHover :: Maybe (Object Int, Icon) } state :: IORef State -state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] None +state = unsafePerformIO $ newIORef $ State [] [] (0, 0, 1, 1) [] [] None Nothing +iconEvaluateSVG :: SVG +iconEvaluateSVG = unsafePerformIO $ My.getDataFileName "data/icon_evaluate.svg" >>= svgNewFromFile +iconCollapseSVG :: SVG +iconCollapseSVG = unsafePerformIO $ My.getDataFileName "data/icon_collapse.svg" >>= svgNewFromFile +hoverEvaluateSVG :: SVG +hoverEvaluateSVG = unsafePerformIO $ My.getDataFileName "data/hover_evaluate.svg" >>= svgNewFromFile +hoverCollapseSVG :: SVG +hoverCollapseSVG = unsafePerformIO $ My.getDataFileName "data/hover_collapse.svg" >>= svgNewFromFile + -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program. redraw :: WidgetClass w => w -> IO () @@ -57,9 +85,9 @@ s <- readIORef state Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas - boundingBoxes <- render canvas (draw s rw2 rh2) + (bbs, hibbs) <- render canvas (draw s rw2 rh2) - modifyIORef state (\s' -> s' {bounds = boundingBoxes}) + modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs}) -- | Export the visualization to an SVG file export :: DrawFunction -> String -> IO () @@ -73,55 +101,98 @@ return () -draw :: State -> Int -> Int -> Render [(Object Int, Rectangle)] +draw :: State -> Int -> Int -> Render ([(Object Int, Rectangle)], [(Object Int, [(Icon, Rectangle)])]) draw s rw2 rh2 = do - vS <- liftIO $ readIORef visState + if null $ boxes s then return ([], []) + else do + vS <- liftIO $ readIORef visState - -- Line widths don't count to size, let's add a bit - let rw = 0.97 * fromIntegral rw2 - rh = 0.97 * fromIntegral rh2 + -- 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 + ops = operations s + size@(_,_,sw,sh) = totalSize s - -- Proportional scaling - (sx,sy) = (zoomRatio vS * min (rw / sw) (rh / sh), sx) - (ox1,oy1) = (0.5 * fromIntegral rw2, 0.5 * fromIntegral rh2) - (ox2,oy2) = position vS - (ox,oy) = (ox1 + ox2, oy1 + oy2) + -- Proportional scaling + (sx,sy) = (min 1000 $ zoomRatio vS * min (rw / sw) (rh / sh), sx) + (ox1,oy1) = (0.5 * fromIntegral rw2, 0.5 * fromIntegral rh2) + (ox2,oy2) = position vS + (ox,oy) = (ox1 + ox2, oy1 + oy2) - translate ox oy - scale sx sy + translate ox oy + scale sx sy - result <- drawAll (hover s) size ops + 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 + case hover s of + Node n -> do + let Just (x,y,w,_h) = lookup (Node n) result + translate (x + w + hoverIconSpace) y + drawHoverMenu $ iconHover s + _ -> return True + + let trafo (o, (x,y,w,h)) = (o, + ( x * sx + ox -- Transformations to correct scaling and offset + , y * sy + oy + , w * sx + , h * sy + )) + + let toHoverIconBounds (o, (x,y,w,_h)) = (o, map trafo + [ (EvaluateIcon, (x+w, y, hoverIconWidth + hoverIconSpace, hoverIconHeight)) + , (CollapseIcon, (x+w, y+hoverIconHeight, hoverIconWidth + hoverIconSpace, hoverIconHeight)) + ]) + + return (map trafo result, map toHoverIconBounds result) + render :: WidgetClass w => w -> Render b -> IO b render canvas r = do win <- widgetGetDrawWindow canvas renderWithDrawable win r +drawHoverMenu :: Maybe (t, Icon) -> Render Bool +drawHoverMenu x = do + svgRender $ case x of + Just (_, EvaluateIcon) -> hoverEvaluateSVG + _ -> iconEvaluateSVG + + translate 0 hoverIconHeight + + svgRender $ case x of + Just (_, CollapseIcon) -> hoverCollapseSVG + _ -> iconCollapseSVG + -- | 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 + hm <- inHistoryMode + when (not hm) $ case iconHover s of + Nothing -> case hover s of + -- This might fail when a click occurs during an update + Node t -> evaluateClick s t + _ -> return () + + Just (Node t, EvaluateIcon) -> evaluateClick s t + Just (Node t, CollapseIcon) -> collapseClick s t _ -> return () +evaluateClick :: State -> Int -> IO () +evaluateClick s 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 + +collapseClick :: State -> Int -> IO () +collapseClick s t = unless (length (boxes s) <= t) $ do + hide $ boxes s !! t + void $ forkIO $ putMVar visSignal RedrawSignal + evaluate2 :: Box -> IO () evaluate2 b@(Box a) = do c <- getBoxedClosureData b @@ -143,6 +214,9 @@ `catch` \(e :: SomeException) -> putStrLn $ "Caught exception while evaluating: " ++ show e +hide :: Box -> IO () +hide b = modifyMVar_ visHidden (\hs -> return $ b : hs) + -- | 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. @@ -152,23 +226,45 @@ 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 + (mx, my) = mousePos vs - 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 + check (o, (x,y,w,h)) = + if x <= mx && mx <= x + w && + y <= my && my <= y + h + then o else None + check2 (o, (x,y,w,h)) = + if x <= mx && mx <= x + w && + y <= my && my <= y + h + then Just o else Nothing + + validOne (None:xs) = validOne xs + validOne (x:_) = x + validOne _ = None + + validOne2 (Nothing:xs) = validOne2 xs + validOne2 (Just x:_) = Just x + validOne2 _ = Nothing + + let iconHov = case oldHover of + Node n -> validOne2 $ map check2 $ fromJust $ lookup (Node n) $ hoverIconBounds oldS + _ -> Nothing + + case iconHov of + Just i -> do + let ih = Just (oldHover, i) + modifyIORef state $ \s' -> s' {iconHover = ih} + unless (iconHover oldS == ih) $ widgetQueueDraw canvas + + Nothing -> do + let h = validOne $ map check $ bounds oldS + modifyIORef state $ \s' -> s' {hover = h, iconHover = Nothing} + unless (oldHover == h && iconHover oldS == Nothing) $ widgetQueueDraw canvas + -- | Something might have changed on the heap, update the view. -updateObjects :: [(Box, String)] -> IO () -updateObjects bs = do - (ops, bs', size) <- xDotParse bs +updateObjects :: [NamedBox] -> IO () +updateObjects _boxes = do + hidden <- readMVar visHidden + (ops, bs', _ , size) <- xDotParse $ hidden + 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 --- a/src/GHC/Vis/View/Graph/Parser.hs +++ b/src/GHC/Vis/View/Graph/Parser.hs @@ -12,21 +12,24 @@ ) where -import Data.List +import Data.Monoid -import Control.Monad +import qualified Data.Foldable as F +import qualified Data.IntMap as M +import qualified Data.IntSet as S import qualified Data.Text.Lazy as B -import Data.Graph.Inductive hiding (nodes, edges) +import Data.Graph.Inductive hiding (edges, newNodes) -import Data.GraphViz hiding (Ellipse, Polygon, parse) +import Data.GraphViz hiding (toNode, 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.Internal (showClosureFields) import GHC.Vis.Types +import GHC.Vis.View.Common import Graphics.XDot.Types hiding (name, h, Style, Color) import Graphics.XDot.Parser @@ -45,87 +48,122 @@ 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 +graphvizCommand :: GraphvizCommand +graphvizCommand = Dot --- | 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 +-- | A generic algorithm to restrict a graph to the subgraph reachable by certain nodes +reachableSubgraph :: DynGraph gr => [Node] => gr a b => gr a b +reachableSubgraph roots graph = flip delNodes graph $ + filter (`S.notMember` reachableNodes) $ + nodes graph + where + trGraph = trc graph + reachableNodes = S.unions $ map (S.fromList . suc trGraph) roots - 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 +-- | Converts a 'HeapGraph' to a fgl 'Gr', taking into account special +-- representations for BCOs. +convertGraph :: HeapGraph Identifier -> Gr ([String], Int) (String, Int) +convertGraph hg = appEndo (removeGarbage <> addNames <> addEdges <> addNodes) empty + where + HeapGraph hgm = hg - 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 + -- Adds nodes for every closure in the map + -- Special treatment for BCOs: Use the disassembler + addNodes = mconcat [ + Endo (insNode (i, toNode hge)) + | (i,hge) <- M.toList hgm + ] - boxPos :: Box -> Maybe Int - boxPos b = elemIndex b $ map fst rhm + deref = fmap $ hgeClosure . (M.!) hgm - bcoChildren :: [Box] -> IO [Int] - bcoChildren [] = return [] - bcoChildren (b:bs) = case boxPos b of - Nothing -> do c <- getBoxedClosureData b - ptf <- pointersToFollow2 c - bcoChildren (ptf ++ bs) - Just pos -> do children <- bcoChildren bs - return $ pos : children + toNode hge | Just byteCode <- disassembleBCO deref (hgeClosure hge) + -- Does not look nice this way, far too wide + -- = (map show byteCode, 0) + = (["BCO"], length (concatMap F.toList byteCode)) + | otherwise + = (showClosureFields (hgeClosure hge), length $ allPtrs (hgeClosure hge)) - es' <- edges + -- Adds edges between the closurs, treating BCOs specially + addEdges = mconcat [ + Endo (insEdge (i, t, ("",n))) + | (i, hge) <- M.toList hgm + , (t,n) <- toEdges hge + ] + toEdges hge = [ (t, n) | (Just t, n) <- zip myPtrs [0..] ] + where myPtrs | Just byteCode <- disassembleBCO deref (hgeClosure hge) + = concatMap F.toList byteCode + | otherwise + = allPtrs (hgeClosure hge) - 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 + -- Adds the nodes and edges for the names + -- addNameList = zip [-1,-2..] -- Displays from right to left + addNameList = zip [-1,-2..] $ reverse + [ (i,name) + | (i, hge) <- M.toList hgm + , name <- hgeData hge + ] + addNames = mconcat $ map addName addNameList + addName (n,(i,name)) = Endo (insEdge (n, i, (name, 0))) <> Endo (insNode (n, ([""],0))) - xDot <- graphvizWithHandle Dot (defaultVis $ toViewableGraph buildGraph) XDot hGetDot - return (getOperations xDot, getBoxes hm, getSize xDot) + -- Removes nodes not reachable by a named closure + removeGarbage = Endo (reachableSubgraph (map fst addNameList)) -getBoxes :: HeapMap -> [Box] -getBoxes hm = map (\(b,(_,_)) -> b) $ reverse hm +removeOld :: Eq a => [a] -> Maybe a -> Maybe a +removeOld keys (Just x) + | x `elem` keys = Just x + | otherwise = Nothing +removeOld _ x = x --- 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 +-- | 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] -> IO ([(Object Node, Operation)], [Box], [(Object Node, Rectangle)], Rectangle) +xDotParse hidden = do + --(hg, _) <- multiBuildHeapGraph 100 as + (HeapGraph hg'', _) <- getHeapGraph + let hg' = M.filter (\(HeapGraphEntry b _ _ _) -> not $ b `elem` hidden) hg'' + let hg = HeapGraph $ M.map (\hge -> hge{hgeClosure = fmap (removeOld $ M.keys hg') (hgeClosure hge)}) hg' + --let hg = HeapGraph $ traverse removeOld hg' -defaultVis :: (Graph gr) => gr String String -> DotGraph Node + xDot <- graphvizWithHandle graphvizCommand (defaultVis $ convertGraph hg) XDot hGetDot + + return (getOperations xDot, getBoxes (HeapGraph hg''), getDimensions xDot, getSize xDot) + +getBoxes :: HeapGraph a -> [Box] +getBoxes (HeapGraph hg) = map (\(HeapGraphEntry b _ _ _) -> b) $ M.elems hg + +defaultVis :: (Graph gr) => gr ([String], Int) (String, Int) -> DotGraph Node defaultVis = graphToDot nonClusteredParams -- Somehow (X11Color Transparency) is white, use (RGBA 0 0 0 0) instead -- Ordering OutEdges is not strong enough to force edge ordering, might not look good anyway { globalAttributes = [GraphAttrs [BgColor [toWC $ RGBA 0 0 0 0], FontName fontName, FontSize graphFontSize]] - , fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize] + , fmtNode = \(x,(l,i)) -> if x >= 0 then [ + --xLabel (B.pack "foo"), + nodeLabel l i, + Shape Record, FontName fontName, FontSize nodeFontSize] + -- x < 0: Invisible marker nodes + else [Shape PointShape, Style [SItem Invisible []]] --, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize, Style [SItem Filled []], FillColor [RGBA 255 255 255 255], Color [RGBA 0 0 0 255]] --, fmtNode = \ (_,l) -> [toLabel l, FontName fontName, FontSize nodeFontSize, Shape PlainText] - , fmtEdge = \ (_,_,l) -> [toLabel l, FontName fontName, FontSize edgeFontSize] + , fmtEdge = \ (_,_,(l,i)) -> [ + TailPort (LabelledPort (PN (B.pack (show i))) Nothing), + toLabel l, + FontName fontName, FontSize edgeFontSize] } + where + {- + All pointer origins below the constructor: + nodeLabel l 0 = Label $ RecordLabel [FieldLabel (B.pack l) | l <- ls] + nodeLabel l i = Label $ RecordLabel [ + FlipFields [ + FlipFields [FieldLabel (B.pack l) | l <- ls] ++ + FlipFields [PortName (PN (B.pack (show j))) | j <- [0..i-1]] + ]] + -} + {- + All pointer following the constructor on the right: + -} + nodeLabel ls i = Label $ RecordLabel $ + [FieldLabel (B.pack l) | l <- ls] ++ + [ PortName (PN (B.pack (show j))) | j <- [0..i-1]] diff --git a/src/GHC/Vis/View/List.hs b/src/GHC/Vis/View/List.hs --- a/src/GHC/Vis/View/List.hs +++ b/src/GHC/Vis/View/List.hs @@ -29,9 +29,9 @@ import Control.Monad import Data.IORef +import Data.List import System.IO.Unsafe -import GHC.Vis.Internal import GHC.Vis.Types hiding (State, View(..)) import GHC.Vis.View.Common @@ -43,12 +43,13 @@ { objects :: [(Box, String, [VisObject])] , bounds :: [(String, Rectangle)] , hover :: Maybe String + , totalSize :: Rectangle } type RGB = (Double, Double, Double) state :: IORef State -state = unsafePerformIO $ newIORef $ State [] [] Nothing +state = unsafePerformIO $ newIORef $ State [] [] Nothing (0, 0, 1, 1) layout' :: IORef (Maybe PangoLayout) layout' = unsafePerformIO $ newIORef Nothing @@ -96,8 +97,8 @@ s <- readIORef state Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas - boundingBoxes <- render canvas (draw s rw2 rh2) - modifyIORef state (\s' -> s' {bounds = boundingBoxes}) + (size, boundingBoxes) <- render canvas (draw s rw2 rh2) + modifyIORef state (\s' -> s' {totalSize = size, bounds = boundingBoxes}) #ifdef SDL_WINDOW getState :: IO State @@ -113,15 +114,14 @@ export drawFn file = do s <- readIORef state - drawFn file (fromIntegral xSize) (fromIntegral ySize) - (\surface -> renderWith surface (draw s xSize ySize)) + let (_, _, xSize, ySize) = totalSize s - return () + drawFn file xSize ySize + (\surface -> renderWith surface (draw s 0 0)) - where xSize = 500 :: Int - ySize = 500 :: Int + return () -draw :: State -> Int -> Int -> Render [(String, Rectangle)] +draw :: State -> Int -> Int -> Render (Rectangle, [(String, Rectangle)]) draw s rw2 rh2 = do let os = objects s objs = map (\(_,_,x) -> x) os @@ -151,12 +151,13 @@ (ox,oy) = (ox2 - (zoomRatio vS - 1) * rw / 2, oy2 - (zoomRatio vS - 1) * rh / 2) translate ox oy - scale sx sy + unless (rw2 == 0 || rh2 == 0) $ + scale sx sy let rpos = scanl (\a b -> a + b + 30) 30 pos result <- mapM (drawEntry s maxNameWidth 0) (zip3 objs rpos names) - return $ map (\(o, (x,y,w,h)) -> (o, (x*sx+ox,y*sy+oy,w*sx,h*sy))) $ concat result + return ((0, 0, sw, sh), 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 @@ -169,7 +170,8 @@ click = do s <- readIORef state - case hover s of + hm <- inHistoryMode + when (not hm) $ case hover s of Just t -> do evaluate t -- Without forkIO it would hang indefinitely if some action is currently @@ -198,10 +200,13 @@ unless (oldHover == hover s) $ widgetQueueDraw canvas -- | Something might have changed on the heap, update the view. -updateObjects :: [(Box, String)] -> IO () +updateObjects :: [NamedBox] -> IO () updateObjects boxes = do - os <- parseBoxes boxes - let objs = zipWith (\(x,y) z -> (x,y,z)) boxes os + os <- parseBoxes + --(h, is) <- multiBuildHeapGraph 100 $ map fst boxes + -- This is wrong + --let os = visHeapGraph (zipWith (\(b,i) (b',n) -> (i,n)) is boxes) h + let objs = zipWith (\(y,x) z -> (x,intercalate ", " y,z)) boxes os modifyIORef state (\s -> s {objects = objs, hover = Nothing}) drawEntry :: State -> Double -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]