ghc-vis 0.7.0.1 → 0.7.1
raw patch · 9 files changed
+201/−41 lines, 9 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ GHC.Vis: setDepth :: Int -> IO ()
Files
- Setup.hs +5/−1
- data/main.ui +130/−0
- ghc-vis.cabal +1/−1
- ghci +1/−0
- src/GHC/Vis.hs +51/−30
- src/GHC/Vis/Types.hs +1/−0
- src/GHC/Vis/View/Common.hs +4/−1
- src/GHC/Vis/View/Graph/Parser.hs +3/−6
- src/GHC/Vis/View/List.hs +5/−2
Setup.hs view
@@ -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
data/main.ui view
@@ -34,6 +34,122 @@ </object> </child> </object>+ <object class="GtkAdjustment" id="adjustment1">+ <property name="lower">1</property>+ <property name="upper">100000</property>+ <property name="value">100</property>+ <property name="step_increment">1</property>+ <property name="page_increment">10</property>+ </object>+ <object class="GtkDialog" id="depthdialog">+ <property name="can_focus">False</property>+ <property name="border_width">5</property>+ <property name="resizable">False</property>+ <property name="destroy_with_parent">True</property>+ <property name="type_hint">dialog</property>+ <child internal-child="vbox">+ <object class="GtkVBox" id="dialog-vbox5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="spacing">2</property>+ <child internal-child="action_area">+ <object class="GtkHButtonBox" id="dialog-action_area5">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="layout_style">end</property>+ <child>+ <object class="GtkButton" id="depthcancel">+ <property name="label">gtk-cancel</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkButton" id="depthok">+ <property name="label">gtk-ok</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="receives_default">True</property>+ <property name="use_stock">True</property>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">False</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">False</property>+ <property name="fill">True</property>+ <property name="pack_type">end</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <child>+ <object class="GtkLabel" id="depthlabel">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="xalign">1</property>+ <property name="label" translatable="yes">Depth: </property>+ <property name="justify">right</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">0</property>+ </packing>+ </child>+ <child>+ <object class="GtkSpinButton" id="depthspin">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="invisible_char">●</property>+ <property name="activates_default">True</property>+ <property name="width_chars">4</property>+ <property name="shadow_type">none</property>+ <property name="primary_icon_activatable">False</property>+ <property name="secondary_icon_activatable">False</property>+ <property name="primary_icon_sensitive">True</property>+ <property name="secondary_icon_sensitive">True</property>+ <property name="adjustment">adjustment1</property>+ <property name="climb_rate">1</property>+ <property name="numeric">True</property>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ </object>+ <packing>+ <property name="expand">True</property>+ <property name="fill">True</property>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ </object>+ </child>+ <action-widgets>+ <action-widget response="-6">depthcancel</action-widget>+ <action-widget response="-5">depthok</action-widget>+ </action-widgets>+ </object> <object class="GtkImage" id="image1"> <property name="visible">True</property> <property name="can_focus">False</property>@@ -44,6 +160,11 @@ <property name="can_focus">False</property> <property name="stock">gtk-undo</property> </object>+ <object class="GtkImage" id="image11">+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="stock">gtk-properties</property>+ </object> <object class="GtkImage" id="image2"> <property name="visible">True</property> <property name="can_focus">False</property>@@ -259,6 +380,15 @@ <property name="visible">True</property> <property name="can_focus">False</property> <property name="image">image5</property>+ <property name="use_stock">False</property>+ </object>+ </child>+ <child>+ <object class="GtkImageMenuItem" id="setdepth">+ <property name="label" translatable="yes">Set depth (:setDepth)</property>+ <property name="visible">True</property>+ <property name="can_focus">False</property>+ <property name="image">image11</property> <property name="use_stock">False</property> </object> </child>
ghc-vis.cabal view
@@ -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
ghci view
@@ -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"
src/GHC/Vis.hs view
@@ -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
src/GHC/Vis/Types.hs view
@@ -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
src/GHC/Vis/View/Common.hs view
@@ -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]
src/GHC/Vis/View/Graph/Parser.hs view
@@ -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
src/GHC/Vis/View/List.hs view
@@ -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