ghc-vis 0.4 → 0.5
raw patch · 7 files changed
+208/−34 lines, 7 filesdep ~ghc-heap-view
Dependency ranges changed: ghc-heap-view
Files
- ghc-vis.cabal +3/−3
- src/GHC/Vis.hs +163/−4
- src/GHC/Vis/Internal.hs +12/−10
- src/GHC/Vis/Types.hs +7/−2
- src/GHC/Vis/View/Common.hs +4/−2
- src/GHC/Vis/View/Graph.hs +9/−5
- src/GHC/Vis/View/List.hs +10/−8
ghc-vis.cabal view
@@ -1,5 +1,5 @@ name: ghc-vis-version: 0.4+version: 0.5 license: BSD3 license-file: LICENSE category: GHC, Debug, Development@@ -20,7 +20,7 @@ how it can be used with GHCi's debugger: <http://felsin9.de/nnis/ghc-vis/#combined-debugger> -tested-with: GHC == 7.4.1, GHC == 7.4.2+tested-with: GHC == 7.4.1, GHC == 7.4.2, GHC == 7.6.1 data-files: ghci Extra-source-files: nonghci-test.hs @@ -40,7 +40,7 @@ transformers, gtk == 0.12.*, cairo == 0.12.*,- ghc-heap-view >= 0.3.0.2+ ghc-heap-view >= 0.3.0.3 Hs-source-dirs: src/ Ghc-options: -Wall -fno-warn-unused-do-bind
src/GHC/Vis.hs view
@@ -44,7 +44,11 @@ ) where +#if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch, error)+#else+import Prelude hiding (error)+#endif import Graphics.UI.Gtk hiding (Box, Signal) import qualified Graphics.UI.Gtk.Gdk.Events as E@@ -92,6 +96,15 @@ defaultSize :: (Int, Int) defaultSize = (640, 480) +zoomIncrement :: Double+zoomIncrement = 1.25++positionIncrement :: Double+positionIncrement = 50++bigPositionIncrement :: Double+bigPositionIncrement = 200+ signalTimeout :: Int signalTimeout = 1000000 @@ -168,15 +181,139 @@ return True onMotionNotify canvas False $ \e -> do+ state <- readIORef visState modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)})- runCorrect move >>= \f -> f canvas++ if dragging state+ then do+ let (oldX, oldY) = mousePos state+ (deltaX, deltaY) = (E.eventX e - oldX, E.eventY e - oldY)+ (oldPosX, oldPosY) = position state+ modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)})+ widgetQueueDraw canvas+ else+ runCorrect move >>= \f -> f canvas+ return True onButtonPress canvas $ \e -> do- cf <- runCorrect click- when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) cf+ when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) $+ join $ runCorrect click++ when (E.eventButton e == RightButton && E.eventClick e == SingleClick) $+ modifyIORef visState (\s -> s {dragging = True})++ when (E.eventButton e == MiddleButton && E.eventClick e == SingleClick) $ do+ modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})+ widgetQueueDraw canvas+ return True + onButtonRelease canvas $ \e -> do+ when (E.eventButton e == RightButton) $+ modifyIORef visState (\s -> s {dragging = False})++ return True++ onScroll canvas $ \e -> do+ state <- readIORef visState++ when (E.eventDirection e == ScrollUp) $ do+ let newZoomRatio = zoomRatio state * zoomIncrement+ newPos <- zoomImage canvas state newZoomRatio (mousePos state)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})++ when (E.eventDirection e == ScrollDown) $ do+ let newZoomRatio = zoomRatio state / zoomIncrement+ newPos <- zoomImage canvas state newZoomRatio (mousePos state)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})++ widgetQueueDraw canvas+ return True++ onKeyPress window $ \e -> do+ --putStrLn $ E.eventKeyName e++ state <- readIORef visState++ when (E.eventKeyName e `elem` ["plus", "Page_Up", "KP_Add"]) $ do+ let newZoomRatio = zoomRatio state * zoomIncrement+ (oldX, oldY) = position state+ newPos = (oldX*zoomIncrement, oldY*zoomIncrement)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})++ when (E.eventKeyName e `elem` ["minus", "Page_Down", "KP_Subtract"]) $ do+ let newZoomRatio = zoomRatio state / zoomIncrement+ (oldX, oldY) = position state+ newPos = (oldX/zoomIncrement, oldY/zoomIncrement)+ modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos})++ when (E.eventKeyName e `elem` ["0", "equal"]) $+ modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)})++ when (E.eventKeyName e `elem` ["Left", "h", "a"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x + positionIncrement+ in s {position = (newX, y)})++ when (E.eventKeyName e `elem` ["Right", "l", "d"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x - positionIncrement+ in s {position = (newX, y)})++ when (E.eventKeyName e `elem` ["Up", "k", "w"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y + positionIncrement+ in s {position = (x, newY)})++ when (E.eventKeyName e `elem` ["Down", "j", "s"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y - positionIncrement+ in s {position = (x, newY)})++ when (E.eventKeyName e `elem` ["H", "A"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x + bigPositionIncrement+ in s {position = (newX, y)})++ when (E.eventKeyName e `elem` ["L", "D"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newX = x - bigPositionIncrement+ in s {position = (newX, y)})++ when (E.eventKeyName e `elem` ["K", "W"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y + bigPositionIncrement+ in s {position = (x, newY)})++ when (E.eventKeyName e `elem` ["J", "S"]) $+ modifyIORef visState (\s ->+ let (x,y) = position s+ newY = y - bigPositionIncrement+ in s {position = (x, newY)})++ when (E.eventKeyName e `elem` ["space", "Return", "KP_Enter"]) $+ join $ runCorrect click++ when (E.eventKeyName e `elem` ["v"]) $+ put SwitchSignal++ when (E.eventKeyName e `elem` ["c"]) $+ put ClearSignal++ when (E.eventKeyName e `elem` ["u"]) $+ put UpdateSignal++ widgetQueueDraw canvas+ return True+ widgetShowAll window reactThread <- forkIO $ react canvas window@@ -235,7 +372,7 @@ #ifdef GRAPH_VIEW where doSwitch = isGraphvizInstalled >>= \gvi -> if gvi- then modifyIORef visState (\s -> s {T.view = succN (T.view s)})+ then modifyIORef visState (\s -> s {T.view = succN (T.view s), zoomRatio = 1, position = (0, 0)}) else putStrLn "Cannot switch view: Graphviz not installed" succN GraphView = ListView@@ -248,3 +385,25 @@ runCorrect f = do s <- readIORef visState return $ f $ views !! fromEnum (T.view s)++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)++ let (oldPosX, oldPosY) = position s+ zoom = newZoomRatio / zoomRatio s+ newPos = (oldPosX * zoom, oldPosY * zoom)++ return newPos++-- Zoom into mouse, but only working from (0,0)+-- newPos = ( oldPosX + x * zoomRatio s - x * newZoomRatio+-- , oldPosY + y * zoomRatio s - y * newZoomRatio )++-- Zoom into center:+-- newPos = ( oldPosX * zoomIncrement+-- , oldPosY * zoomIncrement )
src/GHC/Vis/Internal.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash, DeriveDataTypeable, NoMonomorphismRestriction, RankNTypes #-}+{-# LANGUAGE CPP, MagicHash, DeriveDataTypeable, NoMonomorphismRestriction, RankNTypes #-} {- | Module : GHC.Vis.Internal@@ -16,7 +16,9 @@ ) where +#if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch)+#endif import GHC.Vis.Types import GHC.HeapView hiding (name, pkg, modl, fun, arrWords)@@ -392,13 +394,13 @@ 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--- 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 (APStackClosure _ fun pl) = do+ name <- getSetName b+ 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 _ (MVarClosure _ qHead qTail qValue) = do cHead <- liftM mbParens $ contParse qHead@@ -523,8 +525,8 @@ showClosure PAPClosure{} = "PAP" ---showClosure APStackClosure{}--- = "APStack"+showClosure APStackClosure{}+ = "APStack" showClosure BCOClosure{} = "BCO"
src/GHC/Vis/Types.hs view
@@ -7,6 +7,7 @@ -} module GHC.Vis.Types (+ Point, DrawFunction, Signal(..), View(..),@@ -55,8 +56,12 @@ -- | 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+ { mousePos :: Point -- ^ Current position of the mouse, updated with every movement+ , view :: ViewType -- ^ What kind of visualization is currently running+ , zoomRatio :: Double -- ^ How much the window is zoomed in+ , position :: Point -- ^ Current position in the zoom+ , dragging :: Bool -- ^ Whether the mouse is dragging+ , wasDragged :: Bool -- ^ Whether the mouse was actually dragged } -- | An entry in a 'HeapMap', consisting of an identifier and a parsed GHC heap entry
src/GHC/Vis/View/Common.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} {- | Module : GHC.Vis.View.Common Copyright : (c) Dennis Felsing@@ -15,7 +15,9 @@ ) where +#if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch)+#endif import Control.Concurrent import Control.DeepSeq@@ -39,7 +41,7 @@ -- | Internal state of the visualization visState :: IORef State-visState = unsafePerformIO $ newIORef $ State (0, 0) ListView+visState = unsafePerformIO $ newIORef $ State (0, 0) ListView 1 (0, 0) False False -- | All the visualized boxes visBoxes :: MVar [(Box, String)]
src/GHC/Vis/View/Graph.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {- | Module : GHC.Vis.View.Graph Copyright : (c) Dennis Felsing@@ -15,7 +15,9 @@ ) where +#if __GLASGOW_HASKELL__ < 706 import Prelude hiding (catch)+#endif import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, Object) import qualified Graphics.UI.Gtk as Gtk@@ -73,6 +75,8 @@ draw :: State -> Int -> Int -> Render [(Object Int, Rectangle)] draw s rw2 rh2 = 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@@ -81,10 +85,10 @@ 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+ (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) translate ox oy scale sx sy
src/GHC/Vis/View/List.hs view
@@ -119,6 +119,8 @@ pos <- mapM height objs widths <- mapM (mapM width) objs + vS <- liftIO $ readIORef visState+ let rw = 0.98 * fromIntegral rw2 rh = fromIntegral rh2 @@ -128,15 +130,15 @@ sw = maximum widths2 sh = sum (map (+ 30) pos) - 15 - sx = min (rw / sw) (rh / sh)- sy = sx- ox = 0- oy = 0+ (sx,sy) = (zoomRatio vS * min (rw / sw) (rh / sh), sx)+ (ox2,oy2) = position vS+ (ox,oy) = (ox2 - (zoomRatio vS - 1) * rw / 2, oy2 - (zoomRatio vS - 1) * rh / 2) + 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)+ 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 @@ -186,10 +188,10 @@ let objs = zipWith (\(x,y) z -> (x,y,z)) boxes os modifyIORef state (\s -> s {objects = objs, hover = Nothing}) -drawEntry :: State -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]-drawEntry s nameWidth (obj, pos, name) = do+drawEntry :: State -> Double -> Double -> ([VisObject], Double, String) -> Render [(String, Rectangle)]+drawEntry s nameWidth xPos (obj, pos, name) = do save- translate 0 pos+ translate xPos pos moveTo 0 0 drawBox s $ Unnamed name translate nameWidth 0