Switch to GTK3

Author: TeofilC

GUI/BookmarkView.hs

@@ -117,7 +117,7 @@ bookmarkViewNew builder BookmarkViewActions{..} = do
           (ts,_) <- listStoreGetValue bookmarkStore pos
           bookmarkViewGotoBookmark ts
 
-    onRowActivated bookmarkTreeView $ \[pos] _ -> do
+    bookmarkTreeView `on` rowActivated $ \[pos] _ -> do
       (ts, _) <- listStoreGetValue bookmarkStore pos
       bookmarkViewGotoBookmark ts
 

GUI/Dialogs.hs

@@ -8,6 +8,7 @@ import Graphics.UI.Gtk
 
 import Data.Version (showVersion)
 import System.FilePath
+import Control.Monad.Trans
 
 
 -------------------------------------------------------------------------------
@@ -32,7 +33,7 @@ aboutDialog parent
          aboutDialogWebsite   := "http://www.haskell.org/haskellwiki/ThreadScope",
          windowTransientFor   := toWindow parent
         ]
-      onResponse dialog $ \_ -> widgetDestroy dialog
+      dialog `on` response $ \_ -> widgetDestroy dialog
       widgetShow dialog
 
 -------------------------------------------------------------------------------
@@ -59,7 +60,7 @@ openFileDialog parent  open
        fileFilterAddPattern allfiles "*"
        fileChooserAddFilter dialog allfiles
 
-       onResponse dialog $ \response -> do
+       dialog `on` response $ \response -> do
          case response of
            ResponseAccept -> do
              mfile <- fileChooserGetFilename dialog
@@ -105,7 +106,7 @@ exportFileDialog parent oldfile save = do
     fileFilterAddPattern pdfFiles "*.pdf"
     fileChooserAddFilter dialog pdfFiles
 
-    onResponse dialog $ \response ->
+    dialog `on` response $ \response ->
       case response of
         ResponseAccept -> do
           mfile <- fileChooserGetFilename dialog
@@ -158,5 +159,5 @@ errorMessageDialog parent headline explanation = do
   dialogAddButton dialog "Close" ResponseClose
   dialogSetDefaultResponse dialog ResponseClose
 
-  onResponse dialog $ \_-> widgetDestroy dialog
+  dialog `on` response $ \_-> widgetDestroy dialog
   widgetShowAll dialog

GUI/EventsView.hs

@@ -100,9 +100,9 @@ eventsViewNew builder EventsViewActions{..} = do
   -----------------------------------------------------------------------------
   -- Drawing
 
-  on drawArea exposeEvent $ liftIO $ do
+  on drawArea draw $ liftIO $ do
     drawEvents eventsView =<< readIORef stateRef
-    return True
+    return ()
 
   -----------------------------------------------------------------------------
   -- Key navigation
@@ -122,7 +122,7 @@ eventsViewNew builder EventsViewActions{..} = do
           return True
 
     key <- eventKeyName
-#if MIN_VERSION_gtk(0,13,0)
+#if MIN_VERSION_gtk3(0,13,0)
     case T.unpack key of
 #else
     case key of
@@ -239,7 +239,7 @@ updateScrollAdjustment :: EventsView -> ViewState -> IO ()
 updateScrollAdjustment EventsView{drawArea, adj}
                        ViewState{lineHeight, eventsState} = do
 
-  (_,windowHeight) <- widgetGetSize drawArea
+  Rectangle _ _ _ windowHeight <- widgetGetAllocation drawArea
   let numLines = case eventsState of
                    EventsEmpty             -> 0
                    EventsLoaded{eventsArr} -> snd (bounds eventsArr) + 1
@@ -276,7 +276,8 @@ drawEvents EventsView{drawArea, adj}
       begin = lower
       end   = min upper (snd (bounds eventsArr))
 
-  win   <- widgetGetDrawWindow drawArea
+  -- TODO: don't use Just here
+  Just win   <- widgetGetWindow drawArea
   style <- get drawArea widgetStyle
   focused <- get drawArea widgetIsFocus
   let state | focused   = StateSelected
@@ -286,7 +287,7 @@ drawEvents EventsView{drawArea, adj}
   layout   <- layoutEmpty pangoCtx
   layoutSetEllipsize layout EllipsizeEnd
 
-  (width,clipHeight) <- widgetGetSize drawArea
+  Rectangle _ _ width clipHeight <- widgetGetAllocation drawArea
   let clipRect = Rectangle 0 0 width clipHeight
 
   let -- With average char width, timeWidth is enough for 24 hours of logs

GUI/Histogram.hs

@@ -16,6 +16,7 @@ import Graphics.UI.Gtk
 import qualified GUI.GtkExtras as GtkExt
 
 import Data.IORef
+import Control.Monad.Trans
 
 data HistogramView =
   HistogramView
@@ -51,7 +52,7 @@ histogramViewNew builder = do
   fontDescriptionSetFamily fd "sans serif"
   widgetModifyFont histogramYScaleArea (Just fd)
 
-  (_, xh) <- widgetGetSize timelineXScaleArea
+  Rectangle _ _ _ xh <- widgetGetAllocation timelineXScaleArea
   let xScaleAreaHeight = fromIntegral xh
       traces = [TraceHistogram]
       paramsHist (w, h) minterval = ViewParameters
@@ -80,13 +81,14 @@ histogramViewNew builder = do
     ++ "Re-run with <tt>+RTS -lf</tt> to generate them."
 
   -- Program the callback for the capability drawingArea
-  on histogramDrawingArea exposeEvent $
+  on histogramDrawingArea draw $
      C.liftIO $ do
        maybeEventArray <- readIORef hecsIORef
-       win <- widgetGetDrawWindow histogramDrawingArea
-       (w, windowHeight) <- widgetGetSize histogramDrawingArea
+       -- TODO: get rid of Just
+       Just win <- widgetGetWindow histogramDrawingArea
+       Rectangle _ _ w windowHeight <- widgetGetAllocation histogramDrawingArea
        case maybeEventArray of
-         Nothing -> return False
+         Nothing -> return ()
          Just hecs
            | null (durHistogram hecs) -> do
                GtkExt.stylePaintLayout
@@ -96,37 +98,38 @@ histogramViewNew builder = do
                  histogramDrawingArea ""
                  4 20
                  layout
-               return True
+               return ()
            | otherwise -> do
                minterval <- readIORef mintervalIORef
                if windowHeight < 80
-                 then return False
+                 then return ()
                  else do
                    let size = (w, windowHeight - firstTraceY)
                        params = paramsHist size minterval
                        rect = Rectangle 0 0 w (snd size)
-                   renderWithDrawable win $
+                   renderWithDrawWindow win $
                      renderTraces params hecs rect
-                   return True
+                   return ()
 
   -- Redrawing histogramYScaleArea
-  histogramYScaleArea `onExpose` \_ -> do
+  histogramYScaleArea `on` draw $ liftIO $ do
     maybeEventArray <- readIORef hecsIORef
     case maybeEventArray of
-      Nothing -> return False
+      Nothing -> return ()
       Just hecs
-        | null (durHistogram hecs) -> return False
+        | null (durHistogram hecs) -> return ()
         | otherwise -> do
-            win <- widgetGetDrawWindow histogramYScaleArea
+            -- TODO: get rid of Just
+            Just win <- widgetGetWindow histogramYScaleArea
             minterval <- readIORef mintervalIORef
-            (_, windowHeight) <- widgetGetSize histogramYScaleArea
+            Rectangle _ _ _ windowHeight <- widgetGetAllocation histogramYScaleArea
             if windowHeight < 80
-              then return False
+              then return ()
               else do
                 let size = (undefined, windowHeight - firstTraceY)
                     params = paramsHist size minterval
-                renderWithDrawable win $
+                renderWithDrawWindow win $
                   renderYScaleArea params hecs histogramYScaleArea
-                return True
+                return ()
 
   return HistogramView{..}

GUI/KeyView.hs

@@ -24,7 +24,8 @@ keyViewNew builder = do
 
     keyTreeView <- builderGetObject builder castToTreeView "key_list"
 
-    dw <- widgetGetDrawWindow keyTreeView
+    -- TODO: get rid of this Just
+    Just dw <- widgetGetWindow keyTreeView
     keyEntries  <- createKeyEntries dw keyData
 
     keyStore    <- listStoreNew keyEntries
@@ -113,7 +114,7 @@ keyData =
   ]
 
 
-createKeyEntries :: DrawableClass dw
+createKeyEntries :: DrawWindowClass dw
                  => dw
                  -> [(String, KeyStyle, Color,String)]
                  -> IO [(String, String, Pixbuf)]
@@ -165,12 +166,12 @@ renderKEvent keyColour = do
   C.relLineTo 0 25
   C.stroke
 
-renderToPixbuf :: DrawableClass dw => dw -> (Int, Int) -> C.Render ()
+renderToPixbuf :: DrawWindowClass dw => dw -> (Int, Int) -> C.Render ()
                -> IO Pixbuf
 renderToPixbuf similar (w, h) draw = do
-  pixmap <- pixmapNew (Just similar) w h Nothing
-  renderWithDrawable pixmap draw
-  Just pixbuf <- pixbufGetFromDrawable pixmap (Rectangle 0 0 w h)
+  -- TODO: is this right???
+  renderWithDrawWindow similar draw
+  pixbuf <- pixbufNewFromWindow similar 0 0 w h
   return pixbuf
 
 -------------------------------------------------------------------------------

GUI/MainWindow.hs

@@ -32,7 +32,6 @@ instance Glib.GObjectClass  MainWindow where
   toGObject = toGObject . mainWindow
   unsafeCastGObject = error "cannot downcast to MainView type"
 
-instance Gtk.ObjectClass    MainWindow
 instance Gtk.WidgetClass    MainWindow
 instance Gtk.ContainerClass MainWindow
 instance Gtk.BinClass       MainWindow

GUI/ProgressView.hs

@@ -16,6 +16,7 @@ import GUI.GtkExtras
 import qualified Control.Concurrent as Concurrent
 import Control.Exception
 import Data.Typeable
+import Control.Monad.Trans
 
 data ProgressView = ProgressView {
     progressWindow :: Gtk.Window,
@@ -95,8 +96,8 @@ new parent cancelAction = do
   progress <- progressBarNew
 
   cancel <- buttonNewFromStock stockCancel
-  onClicked cancel (widgetDestroy win >> cancelAction)
-  onDelete win (\_ -> cancelAction >> return True)
+  cancel `on` buttonActivated $ (widgetDestroy win >> cancelAction)
+  win `on` destroyEvent $ lift cancelAction >> return True
   on win keyPressEvent $ do
     keyVal <- eventKeyVal
     case keyVal of

GUI/SaveAs.hs

@@ -62,14 +62,14 @@ saveAs hecs params'@ViewParameters{xScaleAreaHeight, width,
 
 saveAsPDF :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
 saveAsPDF filename hecs params yScaleArea = do
-  (xoffset, _) <- liftIO $ widgetGetSize yScaleArea
+  Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea
   let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
   withPDFSurface filename (fromIntegral w') (fromIntegral h') $ \surface ->
     renderWith surface drawAll
 
 saveAsPNG :: FilePath -> HECs -> ViewParameters -> DrawingArea -> IO ()
 saveAsPNG filename hecs params yScaleArea = do
-  (xoffset, _) <- liftIO $ widgetGetSize yScaleArea
+  Rectangle _ _ xoffset _ <- liftIO $ widgetGetAllocation yScaleArea
   let (w', h', drawAll) = saveAs hecs params (fromIntegral xoffset) yScaleArea
   withImageSurface FormatARGB32 w' h' $ \surface -> do
     renderWith surface drawAll

GUI/Timeline.hs

@@ -38,6 +38,7 @@ import Graphics.Rendering.Cairo ( liftIO )
 
 import Data.IORef
 import Control.Monad
+import Control.Monad.Trans
 import qualified Data.Text as T
 
 -----------------------------------------------------------------------------
@@ -78,7 +79,7 @@ timelineGetViewParameters :: TimelineView -> IO ViewParameters
 timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef,
                                        timelineState=TimelineState{..}} = do
 
-  (w, _) <- widgetGetSize timelineDrawingArea
+  Rectangle _ _ w _ <- widgetGetAllocation timelineDrawingArea
   scaleValue  <- readIORef scaleIORef
   maxSpkValue <- readIORef maxSpkIORef
 
@@ -90,7 +91,7 @@ timelineGetViewParameters TimelineView{tracesIORef, bwmodeIORef, labelsModeIORef
   bwmode <- readIORef bwmodeIORef
   labelsMode <- readIORef labelsModeIORef
 
-  (_, xScaleAreaHeight) <- widgetGetSize timelineXScaleArea
+  Rectangle _ _ _ xScaleAreaHeight <- widgetGetAllocation timelineXScaleArea
   let histTotalHeight = stdHistogramHeight + histXScaleHeight
       timelineHeight =
         calculateTotalTimelineHeight labelsMode histTotalHeight traces
@@ -169,32 +170,32 @@ timelineViewNew builder actions = do
 
   ------------------------------------------------------------------------
   -- Redrawing labelDrawingArea
-  timelineYScaleArea `onExpose` \_ -> do
+  timelineYScaleArea `on` draw $ liftIO $ do
     maybeEventArray <- readIORef hecsIORef
 
     -- Check to see if an event trace has been loaded
     case maybeEventArray of
-      Nothing   -> return False
+      Nothing   -> return ()
       Just hecs -> do
         traces <- readIORef tracesIORef
         labelsMode <- readIORef labelsModeIORef
         let maxP = maxSparkPool hecs
             maxH = fromIntegral (maxYHistogram hecs)
         updateYScaleArea timelineState maxP maxH Nothing labelsMode traces
-        return True
+        return ()
 
   ------------------------------------------------------------------------
   -- Redrawing XScaleArea
-  timelineXScaleArea `onExpose` \_ -> do
+  timelineXScaleArea `on` draw $ liftIO $ do
     maybeEventArray <- readIORef hecsIORef
 
     -- Check to see if an event trace has been loaded
     case maybeEventArray of
-      Nothing   -> return False
+      Nothing   -> return ()
       Just hecs -> do
         let lastTx = hecLastEventTime hecs
         updateXScaleArea timelineState lastTx
-        return True
+        return ()
 
   ------------------------------------------------------------------------
   -- Allow mouse wheel to be used for zoom in/out
@@ -253,7 +254,7 @@ timelineViewNew builder actions = do
           in withMouseState whenNoMouse >> return True
     keyName <- eventKeyName
     keyVal <- eventKeyVal
-#if MIN_VERSION_gtk(0,13,0)
+#if MIN_VERSION_gtk3(0,13,0)
     case (T.unpack keyName, keyToChar keyVal, keyVal) of
 #else
     case (keyName, keyToChar keyVal, keyVal) of
@@ -277,8 +278,7 @@ timelineViewNew builder actions = do
   ------------------------------------------------------------------------
   -- Redrawing
 
-  on timelineDrawingArea exposeEvent $ do
-     exposeRegion <- eventRegion
+  on timelineDrawingArea draw $ do
      liftIO $ do
        maybeEventArray <- readIORef hecsIORef
 
@@ -290,14 +290,15 @@ timelineViewNew builder actions = do
            -- render either the whole height of the timeline, or the window, whichever
            -- is larger (this just ensure we fill the background if the timeline is
            -- smaller than the window).
-           (_, h) <- widgetGetSize timelineDrawingArea
+           exposeRect <- widgetGetAllocation timelineDrawingArea
+           Rectangle _ _ _ h <- widgetGetAllocation timelineDrawingArea
            let params' = params { height = max (height params) h }
            selection  <- readIORef selectionRef
            bookmarks <- readIORef bookmarkIORef
 
-           renderView timelineState params' hecs selection bookmarks exposeRegion
+           renderView timelineState params' hecs selection bookmarks exposeRect
 
-     return True
+     return ()
 
   on timelineDrawingArea configureEvent $ do
      liftIO $ configureTimelineDrawingArea timelineWin
@@ -357,7 +358,7 @@ updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=T
   labelsMode <- readIORef labelsModeIORef
   let histTotalHeight = stdHistogramHeight + histXScaleHeight
       h = calculateTotalTimelineHeight labelsMode histTotalHeight traces
-  (_,winh) <- widgetGetSize timelineDrawingArea
+  Rectangle _ _ _ winh <- widgetGetAllocation timelineDrawingArea
   let winh' = fromIntegral winh;
       h' = fromIntegral h
   adjustmentSetLower    timelineVAdj 0
@@ -377,7 +378,7 @@ updateTimelineVScroll TimelineView{tracesIORef, labelsModeIORef, timelineState=T
 -- the view at all.
 updateTimelineHPageSize :: TimelineState -> IO ()
 updateTimelineHPageSize TimelineState{..} = do
-  (winw,_) <- widgetGetSize timelineDrawingArea
+  Rectangle _ _ winw _ <- widgetGetAllocation timelineDrawingArea
   scaleValue <- readIORef scaleIORef
   adjustmentSetPageSize timelineAdj (fromIntegral winw * scaleValue)
 
@@ -467,8 +468,9 @@ mouseRelease view@TimelineView{..} TimelineViewActions{..} state button x =
 
 widgetSetCursor :: WidgetClass widget => widget -> Maybe Cursor -> IO ()
 widgetSetCursor widget cursor = do
-#if MIN_VERSION_gtk(0,12,1)
-    dw <- widgetGetDrawWindow widget
+#if MIN_VERSION_gtk3(0,12,1)
+    -- TODO: get rid of this Just
+    Just dw <- widgetGetWindow widget
     drawWindowSetCursor dw cursor
 #endif
     return ()