wip

Author: TeofilC

.github/workflows/ci.yml

@@ -24,8 +24,8 @@ jobs:
         include:
           # The windows build is currently broken
           # See #135
-          #- os: windows-latest
-          #   ghc-version: '9.10'
+          - os: windows-latest
+            ghc-version: '9.10'
           - os: macos-latest
             ghc-version: '9.10'
           # gtk2hs is broken under apline

GUI/EventsView.hs

@@ -15,7 +15,8 @@ module GUI.EventsView (
 import GHC.RTS.Events
 import Debug.Trace
 
-import Graphics.UI.Gtk
+import Graphics.UI.Gtk hiding (rectangle)
+import Graphics.Rendering.Cairo
 import qualified GUI.GtkExtras as GtkExt
 
 import Control.Monad
@@ -303,44 +304,29 @@ drawEvents EventsView{drawArea, adj}
       columnGap  = 20
       descrWidth = width - timeWidth - columnGap
 
-  traceM "draw each"
   sequence_
     [ do when (inside || selected) $
-           GtkExt.stylePaintFlatBox
-             style win
-             state1 ShadowNone
-             clipRect
-             drawArea ""
-             0 (round y) width (round lineHeight)
-         traceM "stylePaint"
+           renderWithDrawWindow win $ do
+             -- TODO: figure out how I can grab the correct color from GTK's style
+             setSourceRGBA 0.2 1 1 0.2
+             rectangle 0 y (fromIntegral width) lineHeight
+             fill
 
          -- The event time
          layoutSetText layout (showEventTime event)
-         traceM "set text"
          layoutSetAlignment layout AlignRight
-         traceM "set align"
          layoutSetWidth layout (Just (fromIntegral timeWidth))
-         traceM "set width"
-         GtkExt.stylePaintLayout
-           style win
-           state2 True
-           clipRect
-           drawArea ""
-           0 (round y)
-           layout
-         traceM "paint layout"
+         renderWithDrawWindow win $ do
+           moveTo 0 y
+           showLayout layout
 
          -- The event description text
          layoutSetText layout (showEventDescr event)
          layoutSetAlignment layout AlignLeft
          layoutSetWidth layout (Just (fromIntegral descrWidth))
-         GtkExt.stylePaintLayout
-           style win
-           state2 True
-           clipRect
-           drawArea ""
-           (timeWidth + columnGap) (round y)
-           layout
+         renderWithDrawWindow win $ do
+           moveTo (fromIntegral $ timeWidth + columnGap) y
+           showLayout layout
 
     | n <- [begin..end]
     , let y = fromIntegral n * lineHeight - yOffset

GUI/GtkExtras.hs

@@ -30,58 +30,6 @@ waitGUI = do
 
 -------------------------------------------------------------------------------
 
-stylePaintFlatBox :: WidgetClass widget
-                  => Style
-                  -> DrawWindow
-                  -> StateType
-                  -> ShadowType
-                  -> Rectangle
-                  -> widget
-                  -> String
-                  -> Int -> Int -> Int -> Int
-                  -> IO ()
-stylePaintFlatBox style window stateType shadowType
-                  clipRect widget detail x y width height =
-  with clipRect $ \rectPtr ->
-  withCString detail $ \detailPtr ->
-  (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 arg10 arg11 -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 -> gtk_paint_flat_box argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 arg10 arg11)
-    style
-    window
-    ((fromIntegral.fromEnum) stateType)
-    ((fromIntegral.fromEnum) shadowType)
-    (castPtr rectPtr)
-    (toWidget widget)
-    detailPtr
-    (fromIntegral x) (fromIntegral y)
-    (fromIntegral width) (fromIntegral height)
-
-stylePaintLayout :: WidgetClass widget
-                 => Style
-                 -> DrawWindow
-                 -> StateType
-                 -> Bool
-                 -> Rectangle
-                 -> widget
-                 -> String
-                 -> Int -> Int
-                 -> PangoLayout
-                 -> IO ()
-stylePaintLayout style window stateType useText
-                  clipRect widget detail x y (PangoLayout _ layout) =
-  with clipRect $ \rectPtr ->
-  withCString detail $ \detailPtr ->
-  (\(Style arg1) (DrawWindow arg2) arg3 arg4 arg5 (Widget arg6) arg7 arg8 arg9 (PangoLayoutRaw arg10) -> withForeignPtr arg1 $ \argPtr1 ->withForeignPtr arg2 $ \argPtr2 ->withForeignPtr arg6 $ \argPtr6 ->withForeignPtr arg10 $ \argPtr10 -> gtk_paint_layout argPtr1 argPtr2 arg3 arg4 arg5 argPtr6 arg7 arg8 arg9 argPtr10)
-    style
-    window
-    ((fromIntegral.fromEnum) stateType)
-    (fromBool useText)
-    (castPtr rectPtr)
-    (toWidget widget)
-    detailPtr
-    (fromIntegral x) (fromIntegral y)
-    layout
-
-
 launchProgramForURI :: String -> IO Bool
 #if mingw32_HOST_OS || mingw32_TARGET_OS
 launchProgramForURI uri = do
@@ -115,12 +63,6 @@ launchProgramForURI uri =
 
 -------------------------------------------------------------------------------
 
-foreign import ccall safe "gtk_paint_flat_box"
-  gtk_paint_flat_box :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> CInt -> CInt -> IO ()
-
-foreign import ccall safe "gtk_paint_layout"
-  gtk_paint_layout :: Ptr Style -> Ptr DrawWindow -> CInt -> CInt -> Ptr () -> Ptr Widget -> Ptr CChar -> CInt -> CInt -> Ptr PangoLayoutRaw -> IO ()
-
 foreign import ccall safe "gtk_show_uri"
   gtk_show_uri :: Ptr Screen -> Ptr CChar -> CUInt -> Ptr (Ptr ()) -> IO CInt
 

GUI/Histogram.hs

@@ -91,13 +91,16 @@ histogramViewNew builder = do
          Nothing -> return ()
          Just hecs
            | null (durHistogram hecs) -> do
-               GtkExt.stylePaintLayout
-                 style win
-                 StateNormal True
-                 (Rectangle 0 0 w windowHeight)
-                 histogramDrawingArea ""
-                 4 20
-                 layout
+               renderWithDrawWindow win $ do
+                 C.moveTo 4 20
+                 showLayout layout
+               -- GtkExt.stylePaintLayout
+               --   style win
+               --   StateNormal True
+               --   (Rectangle 0 0 w windowHeight)
+               --   histogramDrawingArea ""
+               --   4 20
+               --   layout
                return ()
            | otherwise -> do
                minterval <- readIORef mintervalIORef