diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -6,6 +6,8 @@
import Distribution.PackageDescription (PackageDescription)
import System.FilePath
+import System.Info
+import Data.List
main = defaultMainWithHooks $ simpleUserHooks
{ postInst = postInstHook (postInst simpleUserHooks)
@@ -15,7 +17,9 @@
postInstHook oldHook args iflags pDesc lbi = do
let instDataDir = datadir $ absoluteInstallDirs pDesc lbi (fromFlag $ copyDest defaultCopyFlags)
putStrLn "To use ghc-vis you have to load its ghci file in GHCi. To do this automatically when GHCi is started run:"
- putStrLn $ "echo \":script " ++ (instDataDir "ghci") ++ "\" >> ~/.ghci"
+ case stripPrefix "mingw" os of
+ Just _ -> putStrLn $ "echo :script " ++ (instDataDir "ghci") ++ " >> %APPDATA%\\ghc\\ghci.conf"
+ Nothing -> putStrLn $ "echo \":script " ++ (instDataDir "ghci") ++ "\" >> ~/.ghci"
oldHook args iflags pDesc lbi
diff --git a/data/main.ui b/data/main.ui
--- a/data/main.ui
+++ b/data/main.ui
@@ -34,6 +34,122 @@
+
+
+
+
+
+
diff --git a/ghc-vis.cabal b/ghc-vis.cabal
--- a/ghc-vis.cabal
+++ b/ghc-vis.cabal
@@ -1,5 +1,5 @@
name: ghc-vis
-version: 0.7.0.1
+version: 0.7.1
license: BSD3
license-file: LICENSE
category: GHC, Debug, Development
diff --git a/ghci b/ghci
--- a/ghci
+++ b/ghci
@@ -10,6 +10,7 @@
: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
+:def setDepth \x -> return $ "GHC.Vis.setDepth (" ++ x ++ ")"
-- Evaluate one step and update values in ghc-vis
:def su \x -> return $ ":step " ++ x ++ "\n:update"
diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs
--- a/src/GHC/Vis.hs
+++ b/src/GHC/Vis.hs
@@ -46,17 +46,18 @@
clear,
restore,
history,
+ setDepth,
export
)
where
#if __GLASGOW_HASKELL__ < 706
-import Prelude hiding (catch, error)
+import Prelude hiding (catch)
#else
-import Prelude hiding (error)
+import Prelude
#endif
-import Graphics.UI.Gtk hiding (Box, Signal, get, response)
+import Graphics.UI.Gtk hiding (Box, Signal, response)
import qualified Graphics.UI.Gtk.Gdk.Events as E
import System.IO
@@ -177,7 +178,7 @@
update :: IO ()
update = put UpdateSignal
--- | Clear the visualization window, removing all expressions from it.
+-- | Clear the visualization window, removing all expressions from it
clear :: IO ()
clear = put ClearSignal
@@ -189,6 +190,12 @@
history :: (Int -> Int) -> IO ()
history = put . HistorySignal
+-- | Set the maximum depth for following closures on the heap
+setDepth :: Int -> IO ()
+setDepth newDepth
+ | newDepth > 0 = modifyIORef visState (\s -> s {heapDepth = newDepth})
+ | otherwise = error "Heap depth has to be positive"
+
-- | Export the current visualization view to a file, format depends on the
-- file ending. Currently supported: svg, png, pdf, ps
export :: String -> IO ()
@@ -196,8 +203,8 @@
export' :: String -> IO (Maybe String)
export' filename = case mbDrawFn of
- Right error -> do putStrLn error
- return $ Just error
+ Right errorMsg -> do putStrLn errorMsg
+ return $ Just errorMsg
Left _ -> do put $ ExportSignal ((\(Left x) -> x) mbDrawFn) filename
return Nothing
@@ -547,7 +554,8 @@
-- λ> let x = 17 :: Int
-- λ> let ys = [ y | y <- xs, y >= x ]
- x <- multiBuildHeapGraph 10 boxes
+ s <- readIORef visState
+ x <- multiBuildHeapGraph (heapDepth s) boxes
modifyMVar_ visHeapHistory (\(i,xs) -> return (i,x:xs))
runCorrect updateObjects >>= \f -> f boxes
@@ -592,21 +600,24 @@
builder <- builderNew
builderAddFromFile builder =<< My.getDataFileName "data/main.ui"
- let get :: forall cls . GObjectClass cls
- => (GObject -> cls)
- -> String
- -> IO cls
- get = builderGetObject builder
+ let getO :: forall cls . GObjectClass cls
+ => (GObject -> cls)
+ -> String
+ -> IO cls
+ getO = builderGetObject builder
- window <- get castToWindow "window"
- canvas <- get castToDrawingArea "drawingarea"
+ window <- getO castToWindow "window"
+ canvas <- getO castToDrawingArea "drawingarea"
- saveDialog <- get castToFileChooserDialog "savedialog"
- aboutDialog <- get castToAboutDialog "aboutdialog"
+ saveDialog <- getO castToFileChooserDialog "savedialog"
+ aboutDialog <- getO castToAboutDialog "aboutdialog"
- legendDialog <- get castToWindow "legenddialog"
- legendCanvas <- get castToDrawingArea "legenddrawingarea"
+ depthDialog <- getO castToDialog "depthdialog"
+ depthSpin <- getO castToSpinButton "depthspin"
+ legendDialog <- getO castToWindow "legenddialog"
+ legendCanvas <- getO castToDrawingArea "legenddrawingarea"
+
newFilter "*.pdf" "PDF" saveDialog
newFilter "*.svg" "SVG" saveDialog
newFilter "*.ps" "PostScript" saveDialog
@@ -615,22 +626,24 @@
set aboutDialog [aboutDialogVersion := showVersion My.version]
onResponse saveDialog $ fileSave saveDialog
+ onResponse depthDialog $ setDepthDialog depthDialog depthSpin
onResponse aboutDialog $ const $ widgetHide aboutDialog
onDelete saveDialog $ const $ widgetHide saveDialog >> return True
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 "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)
+ getO castToMenuItem "clear" >>= \item -> onActivateLeaf item clear
+ getO castToMenuItem "switch" >>= \item -> onActivateLeaf item switch
+ getO castToMenuItem "restore" >>= \item -> onActivateLeaf item restore
+ getO castToMenuItem "update" >>= \item -> onActivateLeaf item update
+ getO castToMenuItem "setdepth" >>= \item -> onActivateLeaf item $ widgetShow depthDialog
+ getO castToMenuItem "export" >>= \item -> onActivateLeaf item $ widgetShow saveDialog
+ getO castToMenuItem "quit" >>= \item -> onActivateLeaf item $ widgetDestroy window
+ getO castToMenuItem "about" >>= \item -> onActivateLeaf item $ widgetShow aboutDialog
+ getO castToMenuItem "legend" >>= \item -> onActivateLeaf item $ widgetShow legendDialog
+ getO castToMenuItem "timeback" >>= \item -> onActivateLeaf item $ history (+1)
+ getO castToMenuItem "timeforward" >>= \item -> onActivateLeaf item $ history (\x -> x - 1)
widgetModifyBg canvas StateNormal backgroundColor
widgetModifyBg legendCanvas StateNormal backgroundColor
@@ -665,13 +678,21 @@
mbError <- export' filename
case mbError of
Nothing -> return ()
- Just error -> do
- errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk error
+ Just errorMsg -> do
+ errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk errorMsg
widgetShow errorDialog
onResponse errorDialog $ const $ widgetHide errorDialog
return ()
_ -> return ()
widgetHide fcdialog
+
+setDepthDialog :: Dialog -> SpinButton -> ResponseId -> IO ()
+setDepthDialog depthDialog depthSpin response = do
+ case response of
+ ResponseOk -> do depth <- spinButtonGetValue depthSpin
+ setDepth $ round depth
+ _ -> return ()
+ widgetHide depthDialog
newFilter :: FileChooserClass fc => String -> String -> fc -> IO ()
newFilter filterString name dialog = do
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
@@ -66,6 +66,7 @@
, position :: Point -- ^ Current position in the zoom
, dragging :: Bool -- ^ Whether the mouse is dragging
, wasDragged :: Bool -- ^ Whether the mouse was actually dragged
+ , heapDepth :: Int -- ^ Maximum heap depth to follow
}
-- | Identifier of a closure
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
@@ -52,9 +52,12 @@
visRunning :: MVar Bool
visRunning = unsafePerformIO (newMVar False)
+defaultDepth :: Int
+defaultDepth = 100
+
-- | Internal state of the visualization
visState :: IORef State
-visState = unsafePerformIO $ newIORef $ State (0, 0) ListView 1 (0, 0) False False
+visState = unsafePerformIO $ newIORef $ State (0, 0) ListView 1 (0, 0) False False defaultDepth
-- | All the visualized boxes
visBoxes :: MVar [NamedBox]
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
@@ -64,10 +64,8 @@
-- | 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
+convertGraph (HeapGraph hgm) = appEndo (removeGarbage <> addNames <> addEdges <> addNodes) empty
where
- HeapGraph hgm = hg
-
-- Adds nodes for every closure in the map
-- Special treatment for BCOs: Use the disassembler
addNodes = mconcat [
@@ -84,7 +82,7 @@
| otherwise
= (showClosureFields (hgeClosure hge), length $ allPtrs (hgeClosure hge))
- -- Adds edges between the closurs, treating BCOs specially
+ -- Adds edges between the closures, treating BCOs specially
addEdges = mconcat [
Endo (insEdge (i, t, ("",n)))
| (i, hge) <- M.toList hgm
@@ -97,8 +95,7 @@
= allPtrs (hgeClosure hge)
-- Adds the nodes and edges for the names
- -- addNameList = zip [-1,-2..] -- Displays from right to left
- addNameList = zip [-1,-2..] $ reverse
+ addNameList = zip [-1,-2..] $ reverse -- Reverse to display from left to right
[ (i,name)
| (i, hge) <- M.toList hgm
, name <- hgeData hge
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
@@ -400,12 +400,15 @@
height xs = do
(layout, _) <- pangoLayout ""
(_, PangoRectangle _ _ _ ya) <- liftIO $ layoutGetExtents layout
- let go (Named _ ys) = (ya + 15) + maximum (map go ys)
+ let go (Named _ ys) = (ya + 15) + maxGo ys
go (Unnamed _) = ya
go (Link _) = ya + 2 * padding
go (Thunk _) = ya + 2 * padding
go (Function _) = ya + 2 * padding
- return $ maximum $ map go xs
+
+ maxGo = maximum . (0 :) . map go
+
+ return $ maxGo xs
width :: VisObject -> Render Double
width (Named x ys) = do