diff --git a/data/main.ui b/data/main.ui --- a/data/main.ui +++ b/data/main.ui @@ -1,39 +1,7 @@ + - - - - False - 5 - dialog - ghc-vis - http://felsin9.de/nnis/ghc-vis - Dennis Felsing -Joachim Breitner - - - True - False - 2 - - - True - False - end - - - False - True - end - 0 - - - - - - - - + 1 100000 @@ -41,144 +9,20 @@ 1 10 - - False - 5 - False - True - dialog - - - True - False - 2 - - - True - False - end - - - gtk-cancel - True - True - True - True - - - False - False - 0 - - - - - gtk-ok - True - True - True - True - - - False - False - 1 - - - - - False - True - end - 0 - - - - - True - False - - - True - False - 1 - Depth: - right - - - True - True - 0 - - - - - True - True - ● - True - 4 - none - False - False - True - True - adjustment1 - 1 - True - - - True - True - 1 - - - - - True - True - 1 - - - - - - - - - depthcancel - depthok - - True False - gtk-save + gtk-new True False - gtk-undo + gtk-media-forward True False - gtk-properties - - - True - False - gtk-zoom-in - - - True - False - gtk-zoom-out - - - True - False - gtk-missing-image + gtk-justify-left True @@ -188,118 +32,37 @@ True False - gtk-new + gtk-zoom-in True False - gtk-jump-to + gtk-zoom-out True False - gtk-refresh + gtk-undo True False - gtk-missing-image + gtk-jump-to True False - gtk-justify-left + gtk-refresh True False - gtk-media-rewind + gtk-properties True False - gtk-media-forward - - - False - ghc-vis Legend - 440 - 250 - True - dialog - - - True - False - - - - - False - 5 - ghc-vis Save - GtkFileChooserDialog - dialog - save - - - True - False - 2 - - - True - False - end - - - gtk-cancel - True - True - True - True - - - False - False - 0 - - - - - gtk-save - True - True - True - True - True - True - True - True - - - False - False - 1 - - - - - False - True - end - 0 - - - - - - - - - cancelbutton - savebutton - + gtk-media-rewind False @@ -307,9 +70,10 @@ 640 480 - + True False + vertical True @@ -329,8 +93,9 @@ Clear (:clear, c) True False - image3 + image1 False + True @@ -340,6 +105,7 @@ False image2 False + True @@ -355,6 +121,7 @@ False True True + True @@ -408,8 +175,9 @@ Zoom in (+) True False - image12 + image3 False + True @@ -417,8 +185,9 @@ Zoom out (-) True False - image13 + image4 False + True @@ -426,8 +195,9 @@ Restore collapsed nodes (:restore, C) True False - image10 + image5 False + True @@ -435,8 +205,9 @@ Switch (:switch, v) True False - image4 + image6 False + True @@ -444,8 +215,9 @@ Update (:update, u) True False - image5 + image7 False + True @@ -453,8 +225,9 @@ Set depth (:setDepth) True False - image11 + image8 False + True @@ -476,8 +249,9 @@ Back (:timeback, ,) True False - image8 + image9 False + True @@ -485,8 +259,9 @@ Forward (:timeforward, .) True False - image9 + image10 False + True @@ -508,8 +283,9 @@ Legend True False - image7 + image11 False + True @@ -519,6 +295,7 @@ False True True + True @@ -543,6 +320,235 @@ 1 + + + + + False + 5 + center-on-parent + utility + window + ghc-vis + http://felsin9.de/nnis/ghc-vis + Dennis Felsing +Joachim Breitner + image-missing + + + True + False + vertical + 2 + + + True + False + end + + + False + True + end + 0 + + + + + + + + + + False + 5 + False + True + dialog + window + + + True + False + vertical + 2 + + + True + False + end + + + gtk-cancel + True + True + True + True + + + False + False + 0 + + + + + gtk-ok + True + True + True + True + + + False + False + 1 + + + + + False + True + end + 0 + + + + + True + False + + + True + False + Depth: + right + 1 + + + True + True + 0 + + + + + True + True + ● + True + 4 + none + False + False + adjustment1 + 1 + True + + + True + True + 1 + + + + + True + True + 1 + + + + + + + + + depthcancel + depthok + + + + False + 5 + ghc-vis Save + GtkFileChooserDialog + dialog + west + window + save + + + True + False + vertical + 2 + + + True + False + end + + + gtk-cancel + True + True + True + True + + + False + False + 0 + + + + + gtk-save + True + True + True + True + True + True + True + True + + + False + False + 1 + + + + + False + True + end + 0 + + + + + + + + + cancelbutton + savebutton + + + + False + ghc-vis Legend + 440 + 250 + True + dialog + + + True + False 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.2.9 +version: 0.8 license: BSD3 license-file: LICENSE category: GHC, Debug, Development @@ -8,7 +8,7 @@ author: Dennis Felsing, Joachim Breitner maintainer: Dennis Felsing homepage: http://felsin9.de/nnis/ghc-vis -copyright: Dennis Felsing 2012-2013 +copyright: Dennis Felsing 2012-2016 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 @@ -47,7 +47,7 @@ text >= 0.11 && < 1.3, transformers >= 0.3 && < 0.5, containers >= 0.4 && < 0.6, - gtk >= 0.12 && < 0.15, + gtk3 >= 0.12 && < 0.15, svgcairo >= 0.12 && < 0.14, cairo >= 0.12 && < 0.14, ghc-heap-view >= 0.5 @@ -57,7 +57,7 @@ if flag(graph) Other-modules: GHC.Vis.View.Graph.Parser GHC.Vis.View.Graph Build-depends: graphviz >= 2999.17, - xdot >= 0.2.4 + xdot >= 0.3 Cpp-options: -DGRAPH_VIEW if flag(full) diff --git a/nonghci-test.hs b/nonghci-test.hs --- a/nonghci-test.hs +++ b/nonghci-test.hs @@ -8,7 +8,7 @@ let d = [1..] putStrLn $ show $ d !! 1 - visualization + vis view a "a" view b "b" view c "c" diff --git a/src/GHC/Vis.hs b/src/GHC/Vis.hs --- a/src/GHC/Vis.hs +++ b/src/GHC/Vis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes #-} +{-# LANGUAGE CPP, RankNTypes, ImpredicativeTypes, OverloadedStrings #-} {- | Module : GHC.Vis Copyright : (c) Dennis Felsing @@ -57,12 +57,13 @@ import Prelude #endif -import Graphics.UI.Gtk hiding (Box, Signal, response) -import qualified Graphics.UI.Gtk.Gdk.Events as E +import Graphics.UI.Gtk hiding (Box, Signal) import System.IO import Control.Concurrent import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class import Control.Exception hiding (evaluate) @@ -70,7 +71,7 @@ import Data.IORef import Data.Version -import qualified Data.Text as Text +import Data.Text () import qualified Data.IntMap as M import System.Timeout @@ -257,10 +258,9 @@ ] (uncurry $ windowSetDefaultSize window) defaultSize - onExpose canvas $ const $ do + on canvas draw $ do runCorrect redraw >>= \f -> f canvas - runCorrect move >>= \f -> f canvas - return True + runCorrect move >>= \f -> liftIO $ f canvas dummy <- windowNew @@ -306,158 +306,166 @@ setupGUI :: (WidgetClass w1, WidgetClass w2, WidgetClass w3) => w1 -> w2 -> w3 -> IO () setupGUI window canvas legendCanvas = do - onMotionNotify canvas False $ \e -> do - state <- readIORef visState - modifyIORef visState (\s -> s {mousePos = (E.eventX e, E.eventY e)}) + widgetAddEvents canvas [PointerMotionMask] + on canvas motionNotifyEvent $ do + (x,y) <- eventCoordinates + lift $ do + state <- readIORef visState + modifyIORef visState (\s -> s {mousePos = (x,y)}) - 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 + if dragging state + then do + let (oldX, oldY) = mousePos state + (deltaX, deltaY) = (x - oldX, y - oldY) + (oldPosX, oldPosY) = position state + modifyIORef visState (\s -> s {position = (oldPosX + deltaX, oldPosY + deltaY)}) + widgetQueueDraw canvas + else + runCorrect move >>= \f -> f canvas - return True + return True - onButtonPress canvas $ \e -> do - when (E.eventButton e == LeftButton && E.eventClick e == SingleClick) $ - join $ runCorrect click + on canvas buttonPressEvent $ do + button <- eventButton + eClick <- eventClick + lift $ do + when (button == LeftButton && eClick == SingleClick) $ + join $ runCorrect click - when (E.eventButton e == RightButton && E.eventClick e == SingleClick) $ - modifyIORef visState (\s -> s {dragging = True}) + when (button == RightButton && eClick == 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 + when (button == MiddleButton && eClick == 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}) + on canvas buttonReleaseEvent $ do + button <- eventButton + lift $ do + when (button == RightButton) $ + modifyIORef visState (\s -> s {dragging = False}) - return True + return True - onScroll canvas $ \e -> do - state <- readIORef visState + on canvas scrollEvent $ do + direction <- eventScrollDirection + lift $ 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}) + when (direction == ScrollUp) $ 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 + when (direction == ScrollDown) $ do + let newZoomRatio = zoomRatio state / zoomIncrement + newPos <- zoomImage canvas state newZoomRatio (mousePos state) + modifyIORef visState (\s -> s {zoomRatio = newZoomRatio, position = newPos}) - onKeyPress window $ \e -> do - state <- readIORef visState + widgetQueueDraw canvas + return True -#if MIN_VERSION_gtk(0,13,0) - let eventKeyName = Text.unpack . E.eventKeyName -#else - let eventKeyName = E.eventKeyName -#endif + on window keyPressEvent $ do + eKeyName <- eventKeyName + lift $ do + state <- readIORef visState - when (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 (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 (eKeyName `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 (eventKeyName e `elem` ["0", "equal"]) $ - modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)}) + when (eKeyName `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 (eventKeyName e `elem` ["Left", "h", "a"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newX = x + positionIncrement - in s {position = (newX, y)}) + when (eKeyName `elem` ["0", "equal"]) $ + modifyIORef visState (\s -> s {zoomRatio = 1, position = (0, 0)}) - when (eventKeyName e `elem` ["Right", "l", "d"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newX = x - positionIncrement - in s {position = (newX, y)}) + when (eKeyName `elem` ["Left", "h", "a"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newX = x + positionIncrement + in s {position = (newX, y)}) - when (eventKeyName e `elem` ["Up", "k", "w"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newY = y + positionIncrement - in s {position = (x, newY)}) + when (eKeyName `elem` ["Right", "l", "d"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newX = x - positionIncrement + in s {position = (newX, y)}) - when (eventKeyName e `elem` ["Down", "j", "s"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newY = y - positionIncrement - in s {position = (x, newY)}) + when (eKeyName `elem` ["Up", "k", "w"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newY = y + positionIncrement + in s {position = (x, newY)}) - when (eventKeyName e `elem` ["H", "A"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newX = x + bigPositionIncrement - in s {position = (newX, y)}) + when (eKeyName `elem` ["Down", "j", "s"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newY = y - positionIncrement + in s {position = (x, newY)}) - when (eventKeyName e `elem` ["L", "D"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newX = x - bigPositionIncrement - in s {position = (newX, y)}) + when (eKeyName `elem` ["H", "A"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newX = x + bigPositionIncrement + in s {position = (newX, y)}) - when (eventKeyName e `elem` ["K", "W"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newY = y + bigPositionIncrement - in s {position = (x, newY)}) + when (eKeyName `elem` ["L", "D"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newX = x - bigPositionIncrement + in s {position = (newX, y)}) - when (eventKeyName e `elem` ["J", "S"]) $ - modifyIORef visState (\s -> - let (x,y) = position s - newY = y - bigPositionIncrement - in s {position = (x, newY)}) + when (eKeyName `elem` ["K", "W"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newY = y + bigPositionIncrement + in s {position = (x, newY)}) - when (eventKeyName e `elem` ["space", "Return", "KP_Enter"]) $ - join $ runCorrect click + when (eKeyName `elem` ["J", "S"]) $ + modifyIORef visState (\s -> + let (x,y) = position s + newY = y - bigPositionIncrement + in s {position = (x, newY)}) - when (eventKeyName e `elem` ["v"]) $ - put SwitchSignal + when (eKeyName `elem` ["space", "Return", "KP_Enter"]) $ + join $ runCorrect click - when (eventKeyName e `elem` ["c"]) $ - put ClearSignal + when (eKeyName `elem` ["v"]) $ + put SwitchSignal - when (eventKeyName e `elem` ["C"]) $ - put RestoreSignal + when (eKeyName `elem` ["c"]) $ + put ClearSignal - when (eventKeyName e `elem` ["u"]) $ - put UpdateSignal + when (eKeyName `elem` ["C"]) $ + put RestoreSignal - when (eventKeyName e `elem` ["comma", "bracketleft"]) $ - put $ HistorySignal (+1) + when (eKeyName `elem` ["u"]) $ + put UpdateSignal - when (eventKeyName e `elem` ["period", "bracketright"]) $ - put $ HistorySignal (\x -> x - 1) + when (eKeyName `elem` ["comma", "bracketleft"]) $ + put $ HistorySignal (+1) - widgetQueueDraw canvas - return True + when (eKeyName `elem` ["period", "bracketright"]) $ + put $ HistorySignal (\x -> x - 1) + widgetQueueDraw canvas + return True + widgetShowAll window reactThread <- forkIO $ react canvas legendCanvas --onDestroy window mainQuit -- Causes :r problems with multiple windows - onDestroy window (quit reactThread) + on window destroyEvent $ lift $ quit reactThread >> return True mainGUI return () @@ -597,9 +605,9 @@ where doSwitch = putStrLn "Cannot switch view: Graph view disabled at build" #endif -runCorrect :: (View -> f) -> IO f +runCorrect :: MonadIO m => (View -> f) -> m f runCorrect f = do - s <- readIORef visState + s <- liftIO $ readIORef visState return $ f $ views !! fromEnum (T.view s) zoomImage :: WidgetClass w1 => w1 -> State -> Double -> T.Point -> IO T.Point @@ -643,36 +651,37 @@ set aboutDialog [aboutDialogVersion := showVersion My.version] - onResponse saveDialog $ fileSave saveDialog - onResponse depthDialog $ setDepthDialog depthDialog depthSpin - onResponse aboutDialog $ const $ widgetHide aboutDialog + on saveDialog response $ fileSave saveDialog + on depthDialog response $ setDepthDialog depthDialog depthSpin + on aboutDialog response $ const $ widgetHide aboutDialog - onDelete saveDialog $ const $ widgetHide saveDialog >> return True - onDelete aboutDialog $ const $ widgetHide aboutDialog >> return True - onDelete legendDialog $ const $ widgetHide legendDialog >> return True + on saveDialog deleteEvent $ lift $ widgetHide saveDialog >> return True + on aboutDialog deleteEvent $ lift $ widgetHide aboutDialog >> return True + on legendDialog deleteEvent $ lift $ widgetHide legendDialog >> return True let setDepthSpin = do s <- readIORef visState spinButtonSetValue depthSpin $ fromIntegral $ heapDepth s - 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 $ setDepthSpin >> 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) - getO castToMenuItem "zoomin" >>= \item -> onActivateLeaf item $ zoom canvas (*1.25) - getO castToMenuItem "zoomout" >>= \item -> onActivateLeaf item $ zoom canvas (/1.25) - getO castToMenuItem "left" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x + positionIncrement, y)) - getO castToMenuItem "right" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x - positionIncrement, y)) - getO castToMenuItem "up" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y + positionIncrement)) - getO castToMenuItem "down" >>= \item -> onActivateLeaf item $ movePos canvas (\(x,y) -> (x, y - positionIncrement)) + getO castToMenuItem "clear" >>= \item -> on item menuItemActivated clear + getO castToMenuItem "switch" >>= \item -> on item menuItemActivated switch + getO castToMenuItem "restore" >>= \item -> on item menuItemActivated restore + getO castToMenuItem "update" >>= \item -> on item menuItemActivated update + getO castToMenuItem "setdepth" >>= \item -> on item menuItemActivated $ setDepthSpin >> widgetShow depthDialog + getO castToMenuItem "export" >>= \item -> on item menuItemActivated $ widgetShow saveDialog + getO castToMenuItem "quit" >>= \item -> on item menuItemActivated $ widgetDestroy window + getO castToMenuItem "about" >>= \item -> on item menuItemActivated $ widgetShow aboutDialog + getO castToMenuItem "legend" >>= \item -> on item menuItemActivated $ widgetShow legendDialog + getO castToMenuItem "timeback" >>= \item -> on item menuItemActivated $ history (+1) + getO castToMenuItem "timeforward" >>= \item -> on item menuItemActivated $ history (\x -> x - 1) + getO castToMenuItem "zoomin" >>= \item -> on item menuItemActivated $ zoom canvas (*1.25) + getO castToMenuItem "zoomout" >>= \item -> on item menuItemActivated $ zoom canvas (/1.25) + getO castToMenuItem "left" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x + positionIncrement, y)) + getO castToMenuItem "right" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x - positionIncrement, y)) + getO castToMenuItem "up" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x, y + positionIncrement)) + getO castToMenuItem "down" >>= \item -> on item menuItemActivated $ movePos canvas (\(x,y) -> (x, y - positionIncrement)) + widgetModifyBg canvas StateNormal backgroundColor widgetModifyBg legendCanvas StateNormal backgroundColor @@ -681,18 +690,18 @@ legendListSVG <- My.getDataFileName "data/legend_list.svg" >>= svgNewFromFile legendGraphSVG <- My.getDataFileName "data/legend_graph.svg" >>= svgNewFromFile - onExpose canvas $ const $ do - boxes <- readMVar visBoxes + on canvas draw $ do + boxes <- liftIO $ readMVar visBoxes if null boxes then renderSVGScaled canvas welcomeSVG else do runCorrect redraw >>= \f -> f canvas - runCorrect move >>= \f -> f canvas - return True + runCorrect move >>= \f -> liftIO $ f canvas + return () - onExpose legendCanvas $ const $ do - state <- readIORef visState + on legendCanvas draw $ do + state <- liftIO $ readIORef visState renderSVGScaled legendCanvas $ case T.view state of ListView -> legendListSVG GraphView -> legendGraphSVG @@ -700,8 +709,8 @@ setupGUI window canvas legendCanvas fileSave :: FileChooserDialog -> ResponseId -> IO () -fileSave fcdialog response = do - case response of +fileSave fcdialog responseId = do + case responseId of ResponseOk -> do Just filename <- fileChooserGetFilename fcdialog mbError <- export' filename case mbError of @@ -709,14 +718,14 @@ Just errorMsg -> do errorDialog <- messageDialogNew Nothing [] MessageError ButtonsOk errorMsg widgetShow errorDialog - onResponse errorDialog $ const $ widgetHide errorDialog + on errorDialog response $ const $ widgetHide errorDialog return () _ -> return () widgetHide fcdialog setDepthDialog :: Dialog -> SpinButton -> ResponseId -> IO () -setDepthDialog depthDialog depthSpin response = do - case response of +setDepthDialog depthDialog depthSpin responseId = do + case responseId of ResponseOk -> do depth <- spinButtonGetValue depthSpin setDepth $ round depth _ -> return () @@ -729,23 +738,23 @@ fileFilterSetName filt $ name ++ " (" ++ filterString ++ ")" fileChooserAddFilter dialog filt -renderSVGScaled :: (WidgetClass w) => w -> SVG -> IO Bool +renderSVGScaled :: (WidgetClass w) => w -> SVG -> Render () renderSVGScaled canvas svg = do - E.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas - win <- widgetGetDrawWindow canvas - renderWithDrawable win $ do - let (cx2, cy2) = svgGetSize svg + rw2 <- liftIO $ widgetGetAllocatedWidth canvas + rh2 <- liftIO $ widgetGetAllocatedHeight canvas + let (cx2, cy2) = svgGetSize svg - (rw,rh) = (fromIntegral rw2, fromIntegral rh2) - (cx,cy) = (fromIntegral cx2, fromIntegral cy2) + (rw,rh) = (fromIntegral rw2, fromIntegral rh2) + (cx,cy) = (fromIntegral cx2, fromIntegral cy2) - -- Proportional scaling - (sx,sy) = (min (rw/cx) (rh/cy), sx) - (ox,oy) = (rw/2 - sx*cx/2, rh/2 - sy*cy/2) + -- Proportional scaling + (sx,sy) = (min (rw/cx) (rh/cy), sx) + (ox,oy) = (rw/2 - sx*cx/2, rh/2 - sy*cy/2) - translate ox oy - scale sx sy - svgRender svg + translate ox oy + scale sx sy + svgRender svg + return () #endif -- Zoom into mouse, but only working from (0,0) 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 @@ -24,7 +24,6 @@ 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 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 @@ -26,7 +26,7 @@ import qualified Control.Monad.State as MS import Graphics.UI.Gtk hiding (Box, Signal, Point) -import Graphics.Rendering.Cairo +import Graphics.Rendering.Cairo hiding (x) -- | A simple Point type Point = (Double, Double) @@ -46,9 +46,9 @@ -- | All functions a view has to provide data View = View - { redraw :: WidgetClass w => w -> IO () + { redraw :: forall w. WidgetClass w => w -> Render () , click :: IO () - , move :: WidgetClass w => w -> IO () + , move :: forall w. WidgetClass w => w -> IO () , updateObjects :: [NamedBox] -> IO () , exportView :: DrawFunction -> String -> IO () } 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 @@ -19,7 +19,7 @@ import Prelude hiding (catch) #endif -import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, Object) +import Graphics.UI.Gtk hiding (Box, Signal, Rectangle, draw) import qualified Graphics.UI.Gtk as Gtk import Graphics.Rendering.Cairo hiding (x, y) @@ -80,14 +80,15 @@ -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program. -redraw :: WidgetClass w => w -> IO () +redraw :: WidgetClass w => w -> Render () redraw canvas = do - s <- readIORef state - Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas + s <- liftIO $ readIORef state + rw2 <- liftIO $ Gtk.widgetGetAllocatedWidth canvas + rh2 <- liftIO $ Gtk.widgetGetAllocatedHeight canvas - (bbs, hibbs) <- render canvas (draw s rw2 rh2) + (bbs, hibbs) <- draw s rw2 rh2 - modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs}) + liftIO $ modifyIORef state (\s' -> s' {bounds = bbs, hoverIconBounds = hibbs}) -- | Export the visualization to an SVG file export :: DrawFunction -> String -> IO () @@ -146,11 +147,6 @@ ]) 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 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 @@ -22,8 +22,8 @@ ) where import Graphics.UI.Gtk (PangoRectangle(..), layoutGetExtents, showLayout, - PangoLayout(..), WidgetClass(..), widgetGetAllocation, widgetGetDrawWindow, - renderWithDrawable, widgetQueueDraw, ascent, layoutSetFontDescription, + PangoLayout, WidgetClass, + widgetQueueDraw, ascent, layoutSetFontDescription, FontMetrics(..), layoutCopy, layoutSetText, layoutGetContext, fontDescriptionFromString, fontDescriptionSetSize, contextGetLanguage, contextGetMetrics, createLayout) @@ -97,13 +97,14 @@ -- | Draw visualization to screen, called on every update or when it's -- requested from outside the program. -redraw :: WidgetClass w => w -> IO () +redraw :: WidgetClass w => w -> Render () redraw canvas = do - s <- readIORef state - Gtk.Rectangle _ _ rw2 rh2 <- widgetGetAllocation canvas + s <- liftIO $ readIORef state + rw2 <- liftIO $ Gtk.widgetGetAllocatedWidth canvas + rh2 <- liftIO $ Gtk.widgetGetAllocatedHeight canvas - (size, boundingBoxes) <- render canvas (draw s rw2 rh2) - modifyIORef state (\s' -> s' {totalSize = size, bounds = boundingBoxes}) + (size, boundingBoxes) <- draw s rw2 rh2 + liftIO $ modifyIORef state (\s' -> s' {totalSize = size, bounds = boundingBoxes}) #ifdef SDL_WINDOW getState :: IO State @@ -163,11 +164,6 @@ result <- mapM (drawEntry s maxNameWidth 0) (zip3 objs rpos names) 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 - win <- widgetGetDrawWindow canvas - renderWithDrawable win r -- | Handle a mouse click. If an object was clicked an 'UpdateSignal' is sent -- that causes the object to be evaluated and the screen to be updated.