Adapt to the changes in GTK4

MetaBrush.cabal

@@ -10,7 +10,7 @@ data-dir:
   assets
 data-files:
   theme.css
-  icon.png
+  icons/*
 description:
 
   MetaBrush is a GUI for brush calligraphy based on Bézier curves.
@@ -118,6 +118,7 @@ executable MetaBrush
 
     other-modules:
         MetaBrush.Action
+      , MetaBrush.Application
       , MetaBrush.Asset.Brushes
       , MetaBrush.Asset.CloseTabButton
       , MetaBrush.Asset.Colours
@@ -175,7 +176,7 @@ executable MetaBrush
       , atomic-file-ops
           ^>= 0.3.0.0
       , bytestring
-          ^>= 0.10.10.0
+           >= 0.10.10.0  && < 0.12
       , directory
            >= 1.3.4.0    && < 1.4
       , dlist
@@ -191,7 +192,7 @@ executable MetaBrush
       , gi-cairo-connector
           ^>= 0.1.0
       , gi-gdk
-           >= 3.0.22     && < 3.1
+           >= 4.0.2      && < 4.1
       , gi-gio
            >= 2.0.27     && < 2.1
       , gi-glib
@@ -199,9 +200,9 @@ executable MetaBrush
       , gi-gobject
           ^>= 2.0.24
       , gi-gtk
-           >= 3.0.35     && < 3.1
+           >= 4.0.3      && < 4.1
-      , gi-gtksource
+      --, gi-gtksource
-           >= 3.0.23     && < 3.1
+      --     >= 3.0.23     && < 3.1
       , hashable
           ^>= 1.3.0.0
       , haskell-gi

app/Main.hs

@@ -1,15 +1,5 @@
-{-# LANGUAGE BangPatterns        #-}
+{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE NegativeLiterals    #-}
-{-# LANGUAGE OverloadedLabels    #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE RecursiveDo         #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeOperators       #-}
 
 module Main
   ( main )
@@ -17,149 +7,24 @@ module Main
 
 -- base
 import Control.Monad
-  ( forever, void )
+  ( void )
-import Control.Monad.ST
-  ( stToIO )
-import Data.Foldable
-  ( for_ )
-import Data.Function
-  ( (&) )
-import Data.Int
-  ( Int32 )
 import System.Exit
-  ( exitSuccess )
+  ( ExitCode(..), exitSuccess, exitWith )
 import GHC.Conc
-  ( forkIO, getNumProcessors, setNumCapabilities )
+  ( getNumProcessors, setNumCapabilities )
 
--- containers
+-- gi-gio
-import Data.Map.Strict
+import qualified GI.Gio as GIO
-  ( Map )
-import qualified Data.Map.Strict as Map
-  ( empty )
-import qualified Data.Sequence as Seq
-  ( fromList )
-import Data.Set
-  ( Set )
-import qualified Data.Set as Set
-  ( empty )
 
--- directory
+-- gi-gobject
-import qualified System.Directory as Directory
+import qualified GI.GObject as GObject
-  ( canonicalizePath )
-
--- generic-lens
-import Data.Generics.Product.Fields
-  ( field' )
-
--- gi-cairo-render
-import qualified GI.Cairo.Render as Cairo
-  ( Render )
-
--- gi-cairo-connector
-import qualified GI.Cairo.Render.Connector as Cairo
-  ( renderWithContext )
-
--- gi-gdk
-import qualified GI.Gdk as GDK
-
--- gi-glib
-import qualified GI.GLib.Constants as GLib
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- lens
-import Control.Lens
-  ( (.~) )
-import Control.Lens.At
-  ( at )
-
--- stm
-import qualified Control.Concurrent.STM as STM
-  ( atomically, retry )
-import qualified Control.Concurrent.STM.TVar as STM
-  ( newTVarIO, readTVar, writeTVar )
-
--- superrecord
-import qualified SuperRecord as Super
-  ( Rec )
-import qualified SuperRecord
-  ( (:=)(..), (&), rnil )
-
--- text
-import qualified Data.Text as Text
-  ( pack )
-
--- transformers
-import Control.Monad.Trans.Reader
-  ( runReaderT )
-
--- unordered-containers
-import Data.HashMap.Strict
-  ( HashMap )
-import qualified Data.HashMap.Strict as HashMap
-  ( fromList )
-
 -- MetaBrush
-import Math.Bezier.Cubic.Fit
+import MetaBrush.Application
-  ( FitParameters(..) )
+  ( runApplication )
-import Math.Bezier.Spline
-  ( Spline(..), Curves(..), Curve(..), NextPoint(..) )
-import Math.Bezier.Stroke
-  ( invalidateCache )
-import Math.Vector2D
-  ( Point2D(..) )
-import MetaBrush.Action
-  ( ActionOrigin(..) )
-import qualified MetaBrush.Asset.Brushes as Asset.Brushes
-  ( circle )
-import MetaBrush.Asset.Colours
-  ( getColours )
-import MetaBrush.Asset.Logo
-  ( drawLogo )
-import MetaBrush.Brush
-  ( Brush, newBrushReference )
-import MetaBrush.Context
-  ( UIElements(..), Variables(..)
-  , Modifier(..)
-  , HoldAction(..), PartialPath(..)
-  )
-import MetaBrush.Document
-  ( emptyDocument
-  , Stroke(..), FocusState(..)
-  , PointData(..)
-  )
-import MetaBrush.Document.History
-  ( DocumentHistory(..), newHistory )
-import MetaBrush.Document.Update
-  ( activeDocument, withActiveDocument )
-import MetaBrush.Event
-  ( handleEvents )
-import MetaBrush.Render.Document
-  ( blankRender, getDocumentRender )
-import MetaBrush.Render.Rulers
-  ( renderRuler )
-import MetaBrush.UI.FileBar
-  ( FileBar(..), createFileBar )
-import MetaBrush.UI.InfoBar
-  ( InfoBar(..), createInfoBar, updateInfoBar )
-import MetaBrush.UI.Menu
-  ( createMenuBar )
-import MetaBrush.UI.Panels
-  ( createPanelBar )
-import MetaBrush.UI.ToolBar
-  ( Tool(..), Mode(..), createToolBar )
-import MetaBrush.UI.Viewport
-  ( Viewport(..), Ruler(..), createViewport )
-import MetaBrush.Unique
-  ( newUniqueSupply
-  , Unique, freshUnique
-  , uniqueMapFromList
-  )
-import MetaBrush.Util
-  ( widgetAddClass, widgetAddClasses )
-import qualified Paths_MetaBrush as Cabal
-  ( getDataFileName )
 
 --------------------------------------------------------------------------------
 
@@ -179,305 +44,14 @@ main = do
   setNumCapabilities caps
 
   ---------------------------------------------------------
-  -- Initialise state
+  -- Run GTK application
 
-  uniqueSupply <- newUniqueSupply
+  application <- GTK.applicationNew ( Just "com.calligraphy.MetaBrush" ) [ GIO.ApplicationFlagsNonUnique ]
+  GIO.applicationRegister application ( Nothing @GIO.Cancellable )
+  void $ GIO.onApplicationActivate application ( runApplication application )
+  exitCode <- GIO.applicationRun application Nothing
+  GObject.objectUnref application
 
-  circleBrush <- Asset.Brushes.circle uniqueSupply
+  case exitCode of
-  circleBrushUnique <- runReaderT freshUnique uniqueSupply
+    0 -> exitSuccess
-  docUnique         <- runReaderT freshUnique uniqueSupply
+    _ -> exitWith ( ExitFailure $ fromIntegral exitCode )
-  strokeUnique      <- runReaderT freshUnique uniqueSupply
-
-  let
-
-    testBrushes :: HashMap Brush Unique
-    testBrushes = HashMap.fromList
-      [ ( circleBrush, circleBrushUnique ) ]
-
-    testDocuments :: Map Unique DocumentHistory
-    testDocuments = fmap newHistory $ uniqueMapFromList
-      [ emptyDocument "Test" docUnique
-      & ( field' @"documentContent" . field' @"strokes" ) .~
-        [ Stroke
-          { strokeName     = "Stroke 1"
-          , strokeVisible  = True
-          , strokeUnique   = strokeUnique
-          , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
-          , strokeSpline   =
-            Spline
-              { splineStart  = mkPoint ( Point2D 10 -20 ) 2
-              , splineCurves = OpenCurves $ Seq.fromList
-                [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D  10  10 ) 5 ), curveData = invalidateCache undefined }
-                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10  10 ) 5 ), curveData = invalidateCache undefined }
-                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
-                ]
-              }
-          }
-        ]
-      & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
-      ]
-        where
-          mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
-          mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
-
-  recomputeStrokesTVar <- STM.newTVarIO @Bool                                        False
-  documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () )     ( const $ pure () )
-  activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                            Nothing
-  openDocumentsTVar    <- STM.newTVarIO @( Map Unique DocumentHistory )              testDocuments
-  brushesTVar          <- STM.newTVarIO @( HashMap Brush Unique )                    testBrushes
-  mousePosTVar         <- STM.newTVarIO @( Maybe ( Point2D Double ) )                Nothing
-  mouseHoldTVar        <- STM.newTVarIO @( Maybe HoldAction )                        Nothing
-  modifiersTVar        <- STM.newTVarIO @( Set Modifier )                            Set.empty
-  toolTVar             <- STM.newTVarIO @Tool                                        Selection
-  modeTVar             <- STM.newTVarIO @Mode                                        PathMode
-  debugTVar            <- STM.newTVarIO @Bool                                        False
-  partialPathTVar      <- STM.newTVarIO @( Maybe PartialPath )                       Nothing
-  fileBarTabsTVar      <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty
-  showGuidesTVar       <- STM.newTVarIO @Bool                                        True
-  maxHistorySizeTVar   <- STM.newTVarIO @Int                                         1000
-  fitParametersTVar    <- STM.newTVarIO @FitParameters
-                            ( FitParameters
-                              { maxSubdiv  = 6
-                              , nbSegments = 12
-                              , dist_tol   = 5e-3
-                              , t_tol      = 1e-4
-                              , maxIters   = 100
-                              }
-                            )
-
-  -- Put all these stateful variables in a record for conciseness.
-  let
-    variables :: Variables
-    variables = Variables {..}
-
-  ---------------------------------------------------------
-  -- Initialise GTK
-
-  void $ GTK.init Nothing
-  Just screen <- GDK.screenGetDefault
-
-  themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
-  cssProvider <- GTK.cssProviderNew
-  GTK.cssProviderLoadFromPath cssProvider themePath
-  GTK.styleContextAddProviderForScreen screen cssProvider 1000
-
-  window <- GTK.windowNew GTK.WindowTypeToplevel
-  windowWidgetPath <- GTK.widgetGetPath window
-  widgetAddClass window "window"
-  GTK.setWindowResizable window True
-  GTK.setWindowDecorated window False
-  GTK.setWindowTitle window "MetaBrush"
-  GTK.windowSetDefaultSize window 1024 768
-  GTK.widgetAddEvents window
-    [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ]
-
-  let
-    baseMinWidth, baseMinHeight :: Int32
-    baseMinWidth  = 480
-    baseMinHeight = 240
-
-  windowGeometry <- GDK.newZeroGeometry
-  GDK.setGeometryMinWidth  windowGeometry baseMinWidth
-  GDK.setGeometryMinHeight windowGeometry baseMinHeight
-  GTK.windowSetGeometryHints window ( Nothing @GTK.Widget )
-    ( Just windowGeometry )
-    [ GDK.WindowHintsMinSize ]
-
-  iconPath <- Directory.canonicalizePath =<< Cabal.getDataFileName "icon.png"
-  GTK.windowSetIconFromFile window iconPath
-
-  colours <- getColours windowWidgetPath
-
-  ---------------------------------------------------------
-  -- Create base UI elements
-
-  baseOverlay <- GTK.overlayNew
-  GTK.setContainerChild window baseOverlay
-
-  uiGrid <- GTK.gridNew
-  GTK.setContainerChild baseOverlay uiGrid
-
-  logo     <- GTK.boxNew   GTK.OrientationVertical   0
-  titleBar <- GTK.boxNew   GTK.OrientationHorizontal 0
-  toolBar  <- GTK.boxNew   GTK.OrientationVertical   0
-  mainPane <- GTK.panedNew GTK.OrientationHorizontal
-  panelBox <- GTK.boxNew   GTK.OrientationVertical   0
-
-  GTK.gridAttach uiGrid logo      0 0 1 2
-  GTK.gridAttach uiGrid titleBar  1 0 2 1
-  GTK.gridAttach uiGrid toolBar   0 2 2 1
-  GTK.gridAttach uiGrid mainPane  2 2 1 1
-
-  mainView     <- GTK.boxNew GTK.OrientationVertical   0
-
-  GTK.panedPack1 mainPane mainView True  False
-  GTK.panedPack2 mainPane panelBox False False
-
-  viewportGrid <- GTK.gridNew
-
-  ---------------------------------------------------------
-  -- Background
-
-  widgetAddClass uiGrid "bg"
-
-  ---------------------------------------------------------
-  -- Title bar
-
-  widgetAddClass titleBar "titleBar"
-
-  --------
-  -- Logo
-
-  widgetAddClass logo "logo"
-
-  logoArea <- GTK.drawingAreaNew
-  GTK.boxPackStart logo logoArea True True 0
-
-  void $ GTK.onWidgetDraw logoArea
-    $ Cairo.renderWithContext ( drawLogo colours )
-
-  ------------
-  -- Title
-
-  title <- GTK.labelNew ( Just "MetaBrush" )
-  widgetAddClasses title [ "text", "title", "plain" ]
-  GTK.boxSetCenterWidget titleBar ( Just title )
-
-  ---------------------------------------------------------
-  -- Main viewport
-
-  viewport@( Viewport {..} ) <- createViewport viewportGrid
-
-  -----------------
-  -- Viewport rendering
-
-  -- Update the document render data in a separate thread.
-  _ <- forkIO $ forever do
-      getRenderDoc <- STM.atomically do
-        needsRecomputation <- STM.readTVar recomputeStrokesTVar
-        case needsRecomputation of
-          False -> STM.retry
-          True  -> do
-              mbDocNow <- fmap present <$> activeDocument variables
-              case mbDocNow of
-                Nothing -> pure ( pure . const $ blankRender colours )
-                Just doc -> do
-                  modifiers      <- STM.readTVar modifiersTVar
-                  mbMousePos     <- STM.readTVar mousePosTVar
-                  mbHoldAction   <- STM.readTVar mouseHoldTVar
-                  mbPartialPath  <- STM.readTVar partialPathTVar
-                  mode           <- STM.readTVar modeTVar
-                  showGuides     <- STM.readTVar showGuidesTVar
-                  debug          <- STM.readTVar debugTVar
-                  fitParameters  <- STM.readTVar fitParametersTVar
-                  STM.writeTVar recomputeStrokesTVar False
-                  let
-                    addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) 
-                    addRulers newRender viewportSize = do
-                      newRender viewportSize
-                      renderRuler
-                        colours viewportSize ViewportOrigin viewportSize
-                        mbMousePos mbHoldAction showGuides
-                        doc
-                  pure
-                    ( addRulers <$> getDocumentRender
-                        colours fitParameters mode debug
-                        modifiers mbMousePos mbHoldAction mbPartialPath
-                        doc
-                    )
-      renderDoc <- stToIO getRenderDoc
-      STM.atomically do
-        STM.writeTVar documentRenderTVar renderDoc
-      void do
-        GDK.threadsAddIdle GLib.PRIORITY_HIGH_IDLE
-          ( False <$ GTK.widgetQueueDraw viewportDrawingArea )
-
-  -- Render the document using the latest available draw data.
-  void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do
-    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
-    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-    -- Get the Cairo instructions for rendering the current document
-    mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
-    render <- case mbDoc of
-      Nothing -> pure ( blankRender colours )
-      Just _  -> STM.atomically do
-        render <- STM.readTVar documentRenderTVar
-        pure ( render ( viewportWidth, viewportHeight ) )
-    Cairo.renderWithContext render ctx
-    pure True
-
-  for_ [ ( rulerCornerDrawingArea , RulerCorner )
-       , ( topRulerDrawingArea    , TopRuler    )
-       , ( leftRulerDrawingArea   , LeftRuler   )
-       ] \ ( rulerDrawingArea, ruler ) -> do
-    void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do
-      viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
-      viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
-      width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
-      height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
-      mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
-        mbMousePos     <- STM.readTVar mousePosTVar
-        mbHoldAction   <- STM.readTVar mouseHoldTVar
-        showGuides     <- STM.readTVar showGuidesTVar
-        pure do
-          renderRuler
-            colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
-            mbMousePos mbHoldAction showGuides
-            doc
-      for_ mbRender \ render -> Cairo.renderWithContext render ctx
-
-      pure True
-
-  ---------------------------------------------------------
-  -- Tool bar
-
-  _ <- createToolBar variables colours toolBar
-
-  ---------------------------------------------------------
-  -- Info bar
-
-  infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
-
-  rec
-
-    ---------------------------------------------------------
-    -- File bar
-
-      fileBar@( FileBar { fileBarBox } ) <-
-        createFileBar
-          colours
-          variables
-          window titleBar title viewport infoBar menu
-
-    ------------
-    -- Menu bar
-
-      let
-        uiElements :: UIElements
-        uiElements = UIElements { menu, fileBar, .. }
-
-      menu <- createMenuBar uiElements variables colours
-
-  GTK.boxPackStart mainView fileBarBox   False False 0
-  GTK.boxPackStart mainView viewportGrid True  True  0
-  GTK.boxPackStart mainView infoBarArea  False False 0
-
-  ---------------------------------------------------------
-  -- Panels
-
-  createPanelBar panelBox
-
-  ---------------------------------------------------------
-  -- Actions
-
-  handleEvents uiElements variables
-
-  ---------------------------------------------------------
-  -- GTK main loop
-
-  GTK.widgetShowAll window
-  mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
-  updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
-  GTK.main
-
-  exitSuccess

assets/theme.css

@@ -1,13 +1,17 @@
-* {
+
+.metabrush * {
   all: unset;
 }
 
+
 /* Colors parsed by application */
 .bg {
   background-color: rgb(41, 40, 40);
+  color: rgb(41, 40, 40);
 }
 .active {
   background-color: rgb(72,70,61);
+  color: rgb(72,70,61);
 }
 .close {
   color: rgb(181,43,43);
@@ -65,21 +69,24 @@
 }
 .viewport {
   background-color: rgb(236, 223, 210);
-  -GtkWidget-window-dragging: false;
+  color: rgb(236, 223, 210);
   min-width: 120px;
   min-height: 90px;
 }
 .viewportScrollbar {
   background-color: rgba(45, 39, 39, 0.66);
+  color: rgba(45, 39, 39, 0.66);
   margin: 4px;
   min-width: 8px;
   min-height: 8px;
 }
 .tabScrollbar {
   background-color: rgba(48, 45, 38, 0.66);
+  color: rgba(48, 45, 38, 0.66);
 }
 .ruler {
   background-color: rgb(237, 226, 154);
+  color: rgb(237, 226, 154);
   min-width:  16px;
   min-height: 16px;
   background-size: 16px 16px;
@@ -97,7 +104,7 @@
   color: rgba(156, 231, 255, 0.5);
 }
 .selected {
-  color: rgba(161,201,236,0.5)
+  color: rgba(161,201,236,0.5);
 }
 .selectedOutline {
   color: rgb(74,150,218);
@@ -113,10 +120,17 @@ tooltip {
   border: 1px solid rgb(28,25,25);
 }
 
+
 .window, .dialog {
-  -GtkWidget-window-dragging: true;
+  border-radius: 0px;
+  border-color: rgb(28,25,25);
+  box-shadow:
+    0px 3px 9px 1px rgba(0,0,0,0),
+    0px 2px 6px 2px rgba(0,0,0,0.2),
+    0px 0px 0px 1px rgba(0,0,0,0.18);
 }
 
+
 /* Basic text colour */
 
 /* Basic text font */
@@ -193,6 +207,7 @@ tooltip {
 .titleBar {
   min-height: 24px;
   font-size: 12px;
+  background-color: rgb(41, 40, 40);
 }
 
 /*
@@ -228,66 +243,65 @@ tooltip {
   background-color: #eadfcc;
 }
 
+/* Menu bar */
 
-.menuBar {
+.menu label {
-  padding-left: 4px;
+  color:rgb(212, 190, 152);
 }
 
-.menuItem {
+.menu :disabled {
-  color: rgba(212, 190, 152,0.5);
+  color:rgb(149,149,149);
-  background-color: rgb(41, 40, 40);
+}
+
+.menu item {
   padding-left: 8px;
   padding-right: 8px;
-  margin-left: 0px;
+  color: rgb(212, 190, 152);
   border-top: 2px solid rgb(41, 40, 40);
 }
 
-/* Menu item hover effect (workaround) */
+.menu :hover {
-.menuItem:selected {
+  color: rgb(212, 190, 152);
   border-color: rgb(72,70,61);
-  color: rgb(212, 190, 152);
 }
 
-/* Styling for active menu item */
+.menu item > * :hover {
-.menuItem:active, .menuItem:checked, .menuItem:hover {
+  border-color: rgb(212, 190, 152);
-  border-color: rgb(234,223,204);
   background-color: rgb(72,70,61);
-  color: rgb(212, 190, 152);
 }
 
-.menuItem > * > * {
+/* Top-level menu items */
-  box-shadow: 2px 4px 3px -1px rgba(28,25,25,0.5);
+
-  border: 1px solid rgb(28,25,25);
+/* TODO: shadows not working properly */
-  border-top: 1px solid rgb(72,70,61);
+.menu item > popover > contents > stack > box > box {
-  color: rgb(212, 190, 152);
+  box-shadow: 0 0 1px 2px rgba(0,0,0,0.5);
 }
 
-.submenuItem {
+/* Submenus without separators */
-  color: rgb(212, 190, 152);
+.menu item > popover > contents > stack > box > box > modelbutton {
-  padding-top: 4px;
-  padding-bottom: 4px;
-  padding-left: 10px;
-  padding-right: 10px;
   background-color: rgb(41, 40, 40);
+  color: rgb(72,70,61);
+  border-top: 0px;
   border-left: 2px solid rgb(41, 40, 40);
+  padding: 2px 10px 6px 10px;
 }
 
-.submenuItem:hover{
+/* Submenus with separators */
+.menu item > popover > contents > stack > box > box > box > box > modelbutton {
+  background-color: rgb(41, 40, 40);
+  color: rgb(72,70,61);
+  border-top: 0px;
+  border-left: 2px solid rgb(41, 40, 40);
+  padding: 2px 10px 6px 10px;
+}
+
+.menu item > popover > contents > stack > box > box > box > separator,
+.menu item > popover > contents > stack > box > box > box > separator :hover {
   background-color: rgb(72,70,61);
+  padding: 1px 0px 0px 1px;
 }
 
-.submenuItem:disabled {
-  color: rgb(149,149,149);
-}
 
-.submenuSeparator {
-  background-color: rgb(28,25,25);
-  padding-top: 1px;
-}
-
-.submenuItem:hover {
-  border-color: rgb(234,223,204);
-}
 
 .accelLabel {
   padding: 2px 8px 2px 0px;
@@ -441,7 +455,6 @@ tooltip {
 .infoBar {
   min-height: 40px;
   font-size:  10px;
-  -GtkWidget-window-dragging: true;
 }
 
 .infoBarInfo {

cabal.project

@@ -30,18 +30,6 @@ source-repository-package
   location: https://github.com/sheaf/generic-lens
   tag: 8d3f0b405894ecade5821c99dcde6efb4a637363
 
--- GHC 9.0 compatibility for 'haskell-gi' and 'haskell-gi-base'
-source-repository-package
-  type: git
-  location: https://github.com/haskell-gi/haskell-gi
-  tag: cc6c25a32288ceef79585e8bba5f197065fb477c
-  subdir: .
-source-repository-package
-  type: git
-  location: https://github.com/haskell-gi/haskell-gi
-  tag: cc6c25a32288ceef79585e8bba5f197065fb477c
-  subdir: base
-
 -- superrecord API improvements
 source-repository-package
   type: git

src/app/MetaBrush/Action.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE DerivingStrategies    #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MonoLocalBinds        #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -24,11 +27,13 @@ import Data.Foldable
 import Data.Int
   ( Int32 )
 import Data.Maybe
-  ( listToMaybe )
+  ( catMaybes, fromMaybe )
 import Data.Traversable
   ( for )
 import Data.Word
   ( Word32 )
+import GHC.Generics
+  ( Generic )
 
 -- acts
 import Data.Act
@@ -59,9 +64,22 @@ import Data.Generics.Product.Fields
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
+-- gi-gio
+import qualified GI.Gio as GIO
+
+-- gi-gobject
+import qualified GI.GObject as GObject
+
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- haskell-gi-base
+import qualified Data.GI.Base as GI
+
+-- hashable
+import Data.Hashable
+  ( Hashable )
+
 -- lens
 import Control.Lens
   ( over, set )
@@ -129,9 +147,7 @@ import MetaBrush.UI.Coordinates
 import MetaBrush.UI.InfoBar
   ( updateInfoBar )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
-  ( TabLocation(..), newFileTab, removeFileTab )
+  ( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab )
-import MetaBrush.UI.Menu
-  ( MenuItem(..), Menu(..), ViewMenu(..) )
 import MetaBrush.UI.ToolBar
   ( Tool(..), Mode(..) )
 import MetaBrush.UI.Viewport
@@ -139,10 +155,22 @@ import MetaBrush.UI.Viewport
 import MetaBrush.Unique
   ( Unique )
 import MetaBrush.Util
-  ( widgetAddClass, widgetAddClasses )
+  ( (>=?=>), (>>?=)
+  , widgetAddClass, widgetAddClasses
+  )
 
 --------------------------------------------------------------------------------
 
+data ActionName
+  = AppAction { actionSimpleName :: !Text }
+  | WinAction { actionSimpleName :: !Text }
+  deriving stock   ( Eq, Ord, Show, Generic )
+  deriving anyclass Hashable
+
+actionPrefix :: ActionName -> Text
+actionPrefix ( AppAction _ ) = "app."
+actionPrefix ( WinAction _ ) = "win."
+
 class HandleAction action where
   handleAction :: UIElements -> Variables -> action -> IO ()
 
@@ -161,7 +189,7 @@ data NewFile = NewFile TabLocation
 
 instance HandleAction NewFile where
   handleAction uiElts vars ( NewFile tabLoc ) =
-    newFileTab False uiElts vars Nothing tabLoc
+    newFileTab uiElts vars Nothing tabLoc
 
 ---------------
 -- Open file --
@@ -178,41 +206,53 @@ instance HandleAction OpenFile where
         ( Just "Open" )
         ( Just "Cancel" )
     GTK.fileChooserSetSelectMultiple fileChooser True
+    GTK.fileChooserSetAction fileChooser GTK.FileChooserActionOpen
     GTK.nativeDialogSetModal fileChooser True
     fileFilter <- GTK.fileFilterNew
     GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
     GTK.fileFilterAddPattern fileFilter "*.mb"
     GTK.fileChooserAddFilter fileChooser fileFilter
-    void $ GTK.nativeDialogRun fileChooser
+    GTK.nativeDialogShow fileChooser
-    filePaths <- GTK.fileChooserGetFilenames fileChooser
+    void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
-    for_ filePaths \ filePath -> do
+      when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
-      knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
+        files <- GTK.fileChooserGetFiles fileChooser
-      ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
+        nbFiles <- GIO.listModelGetNItems files
-      STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
+        fileNames <- catMaybes <$>
-      case mbDoc of
+          for [ ( 0 :: Int ) .. fromIntegral nbFiles - 1 ] \ i ->
-        Left errMessage -> warningDialog window filePath errMessage
+            GIO.listModelGetItem files ( fromIntegral i ) >>?=
-        Right doc -> do
+              ( GI.castTo GIO.File >=?=> GIO.fileGetPath )
-          let
+        for_ fileNames \ filePath -> do
-            newDocHist :: DocumentHistory
+          knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
-            newDocHist = newHistory doc
+          ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
-          newFileTab False uiElts vars ( Just newDocHist ) tabLoc
+          STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
-          updateHistoryState uiElts ( Just newDocHist )
+          case mbDoc of
+            Left errMessage -> warningDialog window filePath errMessage
+            Right doc -> do
+              let
+                newDocHist :: DocumentHistory
+                newDocHist = newHistory doc
+              newFileTab uiElts vars ( Just newDocHist ) tabLoc
+              updateHistoryState uiElts ( Just newDocHist )
+        GObject.objectUnref files
 
-warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO ()
+warningDialog
+  :: ( Show errMess, GTK.IsWindow window )
+  => window -> FilePath -> errMess -> IO ()
 warningDialog window filePath errMess = do
   dialog <- GTK.new GTK.MessageDialog []
   GTK.setMessageDialogText dialog
     ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
   GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
-  GTK.setWindowResizable dialog False
+  GTK.setWindowResizable dialog True
   GTK.setWindowDecorated dialog False
   GTK.windowSetTransientFor dialog ( Just window )
   GTK.windowSetModal dialog True
   widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
   closeButton  <- GTK.dialogAddButton dialog "OK" 1
   widgetAddClass closeButton "dialogButton"
-  _ <- GTK.dialogRun dialog
+  GTK.widgetShow dialog
-  GTK.widgetDestroy dialog
+  void $ GTK.afterDialogResponse dialog \ _ -> do
+    GTK.windowDestroy dialog
 
 -----------------
 -- Open folder --
@@ -228,30 +268,34 @@ instance HandleAction OpenFolder where
         GTK.FileChooserActionSelectFolder
         ( Just "Select Folder" )
         ( Just "Cancel" )
-    GTK.fileChooserSetSelectMultiple fileChooser True
+    GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSelectFolder
     GTK.nativeDialogSetModal fileChooser True
-    void $ GTK.nativeDialogRun fileChooser
+    GTK.nativeDialogShow fileChooser
-    folderPaths <- GTK.fileChooserGetFilenames fileChooser
+    void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
-    for_ folderPaths \ folderPath -> do
+      when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
-      exists <- doesDirectoryExist folderPath
+        folder <- GTK.fileChooserGetFile fileChooser
-      when exists do
+        mbFolderPath <- GIO.fileGetPath folder
-        filePaths <- listDirectory folderPath
+        for_ mbFolderPath \ folderPath -> do
-        for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
+          exists <- doesDirectoryExist folderPath
-          knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
+          when exists do
-          ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
+            filePaths <- listDirectory folderPath
-          STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
+            for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do
-          case mbDoc of
+              knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
-            Left errMessage -> warningDialog window filePath errMessage
+              ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath </> filePath )
-            Right doc -> do
+              STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
-              let
+              case mbDoc of
-                newDocHist :: DocumentHistory
+                Left errMessage -> warningDialog window filePath errMessage
-                newDocHist = newHistory doc
+                Right doc -> do
-              newFileTab False uiElts vars ( Just newDocHist ) tabLoc
+                  let
-              updateHistoryState uiElts ( Just newDocHist )
+                    newDocHist :: DocumentHistory
+                    newDocHist = newHistory doc
+                  newFileTab uiElts vars ( Just newDocHist ) tabLoc
+                  updateHistoryState uiElts ( Just newDocHist )
+        GObject.objectUnref folder
 
----------------
+--------------------
--- Save file --
+-- Save & Save as --
----------------
+--------------------
 
 data Save = Save
   deriving stock Show
@@ -260,6 +304,12 @@ instance HandleAction Save where
   handleAction uiElts vars _ =
     save uiElts vars True
 
+data SaveAs = SaveAs
+  deriving stock Show
+
+instance HandleAction SaveAs where
+  handleAction uiElts vars _ = saveAs uiElts vars True
+
 save :: UIElements -> Variables -> Bool -> IO ()
 save uiElts vars keepOpen = do
   mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
@@ -276,48 +326,42 @@ save uiElts vars keepOpen = do
           modif = if keepOpen then SaveDocument Nothing else CloseDocument
         pure $ UpdateDocAndThen modif ( saveDocument filePath doc )
 
--------------
--- Save as --
--------------
-
-data SaveAs = SaveAs
-  deriving stock Show
-
-instance HandleAction SaveAs where
-  handleAction uiElts vars _ = saveAs uiElts vars True
-
 saveAs :: UIElements -> Variables -> Bool -> IO ()
-saveAs uiElts vars keepOpen = do
+saveAs uiElts vars keepOpen =
-  mbSavePath <- askForSavePath uiElts
+  withSavePath uiElts \ savePath ->
-  for_ mbSavePath \ savePath ->
     modifyingCurrentDocument uiElts vars \ doc -> do
       let
         modif :: DocumentUpdate
         modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
       pure $ UpdateDocAndThen modif ( saveDocument savePath doc )
 
-askForSavePath :: UIElements -> IO ( Maybe FilePath )
+withSavePath :: UIElements -> ( FilePath -> IO () ) -> IO ()
-askForSavePath ( UIElements {..} ) = do
+withSavePath ( UIElements {..} ) action = do
   fileChooser <-
     GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
       GTK.FileChooserActionSave
       ( Just "Save" )
       ( Just "Cancel" )
   GTK.nativeDialogSetModal fileChooser True
-  GTK.fileChooserSetDoOverwriteConfirmation fileChooser True
+  GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSave
   fileFilter <- GTK.fileFilterNew
   GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
   GTK.fileFilterAddPattern fileFilter "*.mb"
   GTK.fileChooserAddFilter fileChooser fileFilter
-  void $ GTK.nativeDialogRun fileChooser
+  GTK.nativeDialogShow fileChooser
-  fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser
+  void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
-    where
+    when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
-      fullFilePath :: FilePath -> FilePath
+      saveFile <- GTK.fileChooserGetFile fileChooser
-      fullFilePath fp
+      mbSavePath <- fmap fullFilePath <$> GIO.fileGetPath saveFile
-        | ".mb" <- takeExtension fp
+      for_ mbSavePath action
-        = fp
+      GObject.objectUnref saveFile
-        | otherwise
+  where
-        = fp <.> "mb"
+    fullFilePath :: FilePath -> FilePath
+    fullFilePath fp
+      | ".mb" <- takeExtension fp
+      = fp
+      | otherwise
+      = fp <.> "mb"
 
 -----------
 -- Close --
@@ -326,7 +370,7 @@ askForSavePath ( UIElements {..} ) = do
 data Close
   = CloseActive -- ^ Close active document.
   | CloseThis   -- ^ Close a specific tab.
-    { docToClose :: Unique }
+    { docToClose :: !Unique }
   deriving stock Show
 
 pattern JustClose, SaveAndClose, CancelClose :: Int32
@@ -364,19 +408,20 @@ instance HandleAction Close where
             cancelButton <- GTK.dialogAddButton dialog "Cancel"         CancelClose
             GTK.dialogSetDefaultResponse dialog 1
             for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
-            choice <- GTK.dialogRun dialog
+            GTK.widgetShow dialog
-            GTK.widgetDestroy dialog
+            void $ GTK.onDialogResponse dialog \ choice -> do
-            case choice of
+              case choice of
-              JustClose    -> closeDocument isActiveDoc documentUnique
+                JustClose    -> closeDocument isActiveDoc documentUnique
-              SaveAndClose -> save uiElts vars False
+                SaveAndClose -> save uiElts vars False
-              _            -> pure ()
+                _            -> pure ()
+              GTK.windowDestroy dialog
           | otherwise
           -> closeDocument isActiveDoc documentUnique
 
       where
         closeDocument :: Bool -> Unique -> IO ()
         closeDocument isActiveDoc unique = do
-          removeFileTab vars unique
+          removeFileTab uiElts vars unique
           when isActiveDoc do
             uiUpdateAction <- STM.atomically do
               STM.writeTVar activeDocumentTVar Nothing
@@ -390,22 +435,43 @@ instance HandleAction Close where
 -- Switch document --
 ---------------------
 
-data SwitchTo = SwitchTo Unique
+data SwitchFromTo =
+  SwitchFromTo
+    { mbPrevActiveDocUnique :: !( Maybe Unique )
+    , newActiveDocUnique    :: !Unique
+    }
   deriving stock Show
 
-instance HandleAction SwitchTo where
+instance HandleAction SwitchFromTo where
   handleAction
     uiElts
     vars@( Variables {..} )
-    ( SwitchTo newUnique ) = do
+    ( SwitchFromTo { mbPrevActiveDocUnique, newActiveDocUnique } )
-      uiUpdateAction <- STM.atomically do
+      | mbPrevActiveDocUnique == Just newActiveDocUnique
-        STM.writeTVar activeDocumentTVar ( Just newUnique )
+      = do
-        mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar
+          mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
-        uiUpdateAction <- updateUIAction uiElts vars
+          for_ mbActiveTab \ ( FileBarTab { fileBarTab = activeTab, fileBarTabButton = activeTabButton } ) -> do
-        pure do
+            GTK.toggleButtonSetActive activeTabButton True
-          uiUpdateAction
+            flags <- GTK.widgetGetStateFlags activeTab
-          updateHistoryState uiElts mbHist
+            GTK.widgetSetStateFlags activeTab
-      uiUpdateAction
+              ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
+              True
+      | otherwise
+      = do
+        uiUpdateAction <- STM.atomically do
+          STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
+          mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
+          uiUpdateAction <- updateUIAction uiElts vars
+          pure do
+            uiUpdateAction
+            for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do
+              mbPrevActiveTab <- Map.lookup prevActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar
+              for_ mbPrevActiveTab \ ( FileBarTab { fileBarTab = prevActiveTab, fileBarTabButton = prevActiveTabButton } ) -> do
+                GTK.toggleButtonSetActive prevActiveTabButton False
+                flags <- GTK.widgetGetStateFlags prevActiveTab
+                GTK.widgetSetStateFlags prevActiveTab ( filter (/= GTK.StateFlagsActive) flags ) True
+            updateHistoryState uiElts mbHist
+        uiUpdateAction
 
 --------------
 -- Quitting --
@@ -415,10 +481,11 @@ data Quit = Quit
   deriving stock Show
 
 instance HandleAction Quit where
-  handleAction ( UIElements { window } ) _ _ = quitEverything window
+  handleAction ( UIElements { application, window } ) _ _ =
+    quitEverything application window
 
-quitEverything :: GTK.Window -> IO ()
+quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
-quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
+quitEverything = GTK.applicationRemoveWindow
 
 ----------------
 -- Undo & Redo --
@@ -556,17 +623,20 @@ data ToggleGuides = ToggleGuides
   deriving stock Show
 
 instance HandleAction ToggleGuides where
-  handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
+  handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
-    guidesWereShown <- STM.atomically do
+    _guidesWereShown <- STM.atomically do
       guidesWereShown <- STM.readTVar showGuidesTVar
       STM.writeTVar showGuidesTVar ( not guidesWereShown )
       pure guidesWereShown
-    let
+    --let
-      newText :: Text
+    --  newText :: Text
-      newText
+    --  newText
-        | guidesWereShown = "Show guides"
+    --    | guidesWereShown = "Show guides"
-        | otherwise       = "Hide guides"
+    --    | otherwise       = "Hide guides"
-    GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
+    --  toggleGuidesWidget :: GTK.Button
+    --  toggleGuidesWidget = menuItemWidget . toggleGuides . sectionItems . viewMenu4 . menuItemSubmenu . view
+    --                     $ menuObject
+    --GTK.buttonSetLabel toggleGuidesWidget newText
     STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
     for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
       GTK.widgetQueueDraw drawingArea
@@ -813,7 +883,7 @@ instance HandleAction MouseRelease where
       1 -> do
         viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
         viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
-        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } )  -> do
+        modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do
           let
             toViewport :: Point2D Double -> Point2D Double
             toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter
@@ -835,7 +905,8 @@ instance HandleAction MouseRelease where
                       changeText = "Create guide"
                     pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
                   | otherwise
-                  -> pure Don'tModifyDoc
+                  -> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc )
+                  -- ^^ force an UI update when releasing a guide inside a ruler area
                   where
                     createGuide :: Bool
                     createGuide
@@ -991,29 +1062,27 @@ instance HandleAction MouseRelease where
 -- Scrolling --
 ---------------
 
-data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
+data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
   deriving stock Show
 
 instance HandleAction Scroll where
   handleAction
-    uiElts@( UIElements { viewport = Viewport {..} } )
+    uiElts
     vars@( Variables {..} )
-    ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do
+    ( Scroll mbMousePos ( Vector2D dx dy ) ) = do
 
-      viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
+      --viewportWidth  <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth  viewportDrawingArea
-      viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
+      --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
 
       unless ( dx == 0 && dy == 0 ) do
         modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
           modifiers <- STM.readTVar modifiersTVar
           let
-            toViewport :: Point2D Double -> Point2D Double
-            toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter
-            -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates)
             mousePos :: Point2D Double
-            mousePos = toViewport ( Point2D x y )
+            mousePos = fromMaybe oldCenter mbMousePos
+            finalMousePos :: Point2D Double
             newDoc :: Document
-            newDoc
+            ( newDoc, finalMousePos )
               -- Zooming using 'Control'.
               | any ( \ case { Control _ -> True; _ -> False } ) modifiers
               = let
@@ -1027,28 +1096,21 @@ instance HandleAction Scroll where
                   newCenter
                     = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
                     • oldCenter
-                in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }
+                in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
               -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
               | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
               = let
                   newCenter :: Point2D Double
                   newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
-                in doc { viewportCenter = newCenter }
+                in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
               -- Vertical scrolling.
               | otherwise
               = let
                   newCenter :: Point2D Double
                   newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
-                in doc { viewportCenter = newCenter }
+                in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
-            finalZoomFactor :: Double
+          for_ mbMousePos \ _ ->
-            finalZoomFactor = zoomFactor     newDoc
+            STM.writeTVar mousePosTVar ( Just finalMousePos )
-            finalCenter :: Point2D Double
-            finalCenter     = viewportCenter newDoc
-            toFinalViewport :: Point2D Double -> Point2D Double
-            toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter
-            finalMousePos :: Point2D Double
-            finalMousePos = toFinalViewport ( Point2D x y )
-          STM.writeTVar mousePosTVar ( Just finalMousePos )
           pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
 
 --------------------
@@ -1067,7 +1129,7 @@ instance HandleAction KeyboardPress where
       for_ ( modifierKey keyCode )
         ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
 
-      case keyCode of
+      case fromIntegral keyCode of
 
         GDK.KEY_Escape -> handleAction uiElts vars Quit
 

src/app/MetaBrush/Action.hs-boot

@@ -1,3 +1,5 @@
+{-# LANGUAGE MonoLocalBinds #-}
+
 module MetaBrush.Action where
 
 -- base
@@ -7,6 +9,14 @@ import Data.Word
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- hashable
+import Data.Hashable
+  ( Hashable )
+
+-- text
+import Data.Text
+  ( Text )
+
 -- MetaBrush
 import Math.Vector2D
   ( Point2D, Vector2D )
@@ -21,6 +31,15 @@ import MetaBrush.Unique
 
 --------------------------------------------------------------------------------
 
+data ActionName
+  = AppAction { actionSimpleName :: !Text }
+  | WinAction { actionSimpleName :: !Text }
+
+instance Eq       ActionName
+instance Ord      ActionName
+instance Show     ActionName
+instance Hashable ActionName
+
 class HandleAction action where
   handleAction :: UIElements -> Variables -> action -> IO ()
 
@@ -44,15 +63,19 @@ instance HandleAction SaveAs
 data Close
   = CloseActive
   | CloseThis
-    { docToClose :: Unique }
+    { docToClose :: !Unique }
 instance HandleAction Close
 
-data SwitchTo = SwitchTo Unique
+data SwitchFromTo =
-instance HandleAction SwitchTo
+  SwitchFromTo
+    { mbPrevActiveDocUnique :: !( Maybe Unique )
+    , newActiveDocUnique    :: !Unique
+    }
+instance HandleAction SwitchFromTo
 
 data Quit = Quit
 instance HandleAction Quit
-quitEverything :: GTK.Window -> IO ()
+quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
 
 data Undo = Undo
 instance HandleAction Undo
@@ -99,7 +122,7 @@ instance HandleAction MouseClick
 data MouseRelease = MouseRelease Word32 ( Point2D Double )
 instance HandleAction MouseRelease
 
-data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
+data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
 instance HandleAction Scroll
 
 data KeyboardPress = KeyboardPress Word32

src/app/MetaBrush/Application.hs

@@ -0,0 +1,498 @@
+
+{-# LANGUAGE BlockArguments    #-}
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE NegativeLiterals  #-}
+{-# LANGUAGE OverloadedLabels  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE RecursiveDo       #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+module MetaBrush.Application
+  ( runApplication )
+  where
+
+-- base
+import Control.Monad
+  ( forever, void )
+import Control.Monad.ST
+  ( stToIO )
+import Data.Foldable
+  ( for_ )
+import Data.Function
+  ( (&) )
+import Data.Int
+  ( Int32 )
+import GHC.Conc
+  ( forkIO )
+
+-- containers
+import Data.Map.Strict
+  ( Map )
+import qualified Data.Map.Strict as Map
+  ( empty )
+import qualified Data.Sequence as Seq
+  ( fromList )
+import Data.Set
+  ( Set )
+import qualified Data.Set as Set
+  ( empty )
+
+-- directory
+import qualified System.Directory as Directory
+  ( canonicalizePath )
+
+-- filepath
+import System.FilePath
+  ( (</>) )
+
+-- generic-lens
+import Data.Generics.Product.Fields
+  ( field' )
+
+-- gi-cairo-render
+import qualified GI.Cairo.Render as Cairo
+  ( Render )
+
+-- gi-cairo-connector
+import qualified GI.Cairo.Render.Connector as Cairo
+  ( renderWithContext )
+
+-- gi-glib
+import qualified GI.GLib as GLib
+
+-- gi-gtk
+import qualified GI.Gtk as GTK
+
+-- lens
+import Control.Lens
+  ( (.~) )
+import Control.Lens.At
+  ( at )
+
+-- stm
+import qualified Control.Concurrent.STM as STM
+  ( atomically, retry )
+import qualified Control.Concurrent.STM.TVar as STM
+  ( newTVarIO, readTVar, writeTVar )
+
+-- superrecord
+import qualified SuperRecord as Super
+  ( Rec )
+import qualified SuperRecord
+  ( (:=)(..), (&), rnil )
+
+-- text
+import qualified Data.Text as Text
+  ( pack )
+
+-- transformers
+import Control.Monad.Trans.Reader
+  ( runReaderT )
+
+-- unordered-containers
+import Data.HashMap.Strict
+  ( HashMap )
+import qualified Data.HashMap.Strict as HashMap
+  ( fromList )
+
+-- MetaBrush
+import Math.Bezier.Cubic.Fit
+  ( FitParameters(..) )
+import Math.Bezier.Spline
+  ( Spline(..), Curves(..), Curve(..), NextPoint(..) )
+import Math.Bezier.Stroke
+  ( invalidateCache )
+import Math.Vector2D
+  ( Point2D(..) )
+import MetaBrush.Action
+  ( ActionOrigin(..) )
+import qualified MetaBrush.Asset.Brushes as Asset.Brushes
+  ( circle )
+import MetaBrush.Asset.Colours
+  ( getColours )
+import MetaBrush.Asset.Logo
+  ( drawLogo )
+import MetaBrush.Brush
+  ( Brush, newBrushReference )
+import MetaBrush.Context
+  ( UIElements(..), Variables(..)
+  , Modifier(..)
+  , HoldAction(..), PartialPath(..)
+  )
+import MetaBrush.Document
+  ( emptyDocument
+  , Stroke(..), FocusState(..)
+  , PointData(..)
+  )
+import MetaBrush.Document.History
+  ( DocumentHistory(..), newHistory )
+import MetaBrush.Document.Update
+  ( activeDocument, withActiveDocument )
+import MetaBrush.Event
+  ( handleEvents )
+import MetaBrush.Render.Document
+  ( blankRender, getDocumentRender )
+import MetaBrush.Render.Rulers
+  ( renderRuler )
+import MetaBrush.UI.FileBar
+  ( FileBar(..), FileBarTab, createFileBar )
+import MetaBrush.UI.InfoBar
+  ( InfoBar(..), createInfoBar, updateInfoBar )
+import MetaBrush.UI.Menu
+  ( createMenuBar, createMenuActions )
+import MetaBrush.UI.Panels
+  ( createPanelBar )
+import MetaBrush.UI.ToolBar
+  ( Tool(..), Mode(..), createToolBar )
+import MetaBrush.UI.Viewport
+  ( Viewport(..), ViewportEventControllers(..)
+  , Ruler(..)
+  , createViewport
+  )
+import MetaBrush.Unique
+  ( newUniqueSupply
+  , Unique, freshUnique
+  , uniqueMapFromList
+  )
+import MetaBrush.Util
+  ( widgetAddClass, widgetAddClasses )
+import qualified Paths_MetaBrush as Cabal
+  ( getDataDir, getDataFileName )
+
+--------------------------------------------------------------------------------
+
+runApplication :: GTK.Application -> IO ()
+runApplication application = do
+
+  ---------------------------------------------------------
+  -- Initialise state
+
+  uniqueSupply <- newUniqueSupply
+
+  circleBrush <- Asset.Brushes.circle uniqueSupply
+  circleBrushUnique <- runReaderT freshUnique uniqueSupply
+  docUnique         <- runReaderT freshUnique uniqueSupply
+  strokeUnique      <- runReaderT freshUnique uniqueSupply
+
+  let
+
+    testBrushes :: HashMap Brush Unique
+    testBrushes = HashMap.fromList
+      [ ( circleBrush, circleBrushUnique ) ]
+
+    testDocuments :: Map Unique DocumentHistory
+    testDocuments = fmap newHistory $ uniqueMapFromList
+      [ emptyDocument "Test" docUnique
+      & ( field' @"documentContent" . field' @"strokes" ) .~
+        [ Stroke
+          { strokeName     = "Stroke 1"
+          , strokeVisible  = True
+          , strokeUnique   = strokeUnique
+          , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique
+          , strokeSpline   =
+            Spline
+              { splineStart  = mkPoint ( Point2D 10 -20 ) 2
+              , splineCurves = OpenCurves $ Seq.fromList
+                [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D  10  10 ) 5 ), curveData = invalidateCache undefined }
+                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10  10 ) 5 ), curveData = invalidateCache undefined }
+                , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined }
+                ]
+              }
+          }
+        ]
+      & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush )
+      ]
+        where
+          mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] )
+          mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil )
+
+  recomputeStrokesTVar <- STM.newTVarIO @Bool                                    False
+  documentRenderTVar   <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () )
+  activeDocumentTVar   <- STM.newTVarIO @( Maybe Unique )                        Nothing
+  openDocumentsTVar    <- STM.newTVarIO @( Map Unique DocumentHistory )          testDocuments
+  brushesTVar          <- STM.newTVarIO @( HashMap Brush Unique )                testBrushes
+  mousePosTVar         <- STM.newTVarIO @( Maybe ( Point2D Double ) )            Nothing
+  mouseHoldTVar        <- STM.newTVarIO @( Maybe HoldAction )                    Nothing
+  modifiersTVar        <- STM.newTVarIO @( Set Modifier )                        Set.empty
+  toolTVar             <- STM.newTVarIO @Tool                                    Selection
+  modeTVar             <- STM.newTVarIO @Mode                                    PathMode
+  debugTVar            <- STM.newTVarIO @Bool                                    False
+  partialPathTVar      <- STM.newTVarIO @( Maybe PartialPath )                   Nothing
+  fileBarTabsTVar      <- STM.newTVarIO @( Map Unique FileBarTab )               Map.empty
+  showGuidesTVar       <- STM.newTVarIO @Bool                                    True
+  maxHistorySizeTVar   <- STM.newTVarIO @Int                                     1000
+  fitParametersTVar    <- STM.newTVarIO @FitParameters
+                            ( FitParameters
+                              { maxSubdiv  = 6
+                              , nbSegments = 12
+                              , dist_tol   = 5e-3
+                              , t_tol      = 1e-4
+                              , maxIters   = 100
+                              }
+                            )
+
+  -- Put all these stateful variables in a record for conciseness.
+  let
+    variables :: Variables
+    variables = Variables {..}
+
+  ---------------------------------------------------------
+  -- GTK UI
+
+  window      <- GTK.applicationWindowNew application
+  display     <- GTK.rootGetDisplay window
+
+  dataPath    <- Directory.canonicalizePath =<< Cabal.getDataDir
+  themePath   <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" )
+  cssProvider <- GTK.cssProviderNew
+  GTK.cssProviderLoadFromPath cssProvider themePath
+  GTK.styleContextAddProviderForDisplay display cssProvider 1000
+
+  windowKeys <- GTK.eventControllerKeyNew
+
+  GTK.eventControllerSetPropagationPhase windowKeys GTK.PropagationPhaseBubble
+
+  widgetAddClasses window [ "metabrush", "window" ]
+  GTK.setWindowResizable window True
+  GTK.setWindowDecorated window True
+  GTK.setWindowTitle window "MetaBrush"
+  GTK.windowSetDefaultSize window 1024 768
+
+  GTK.windowSetIconName window ( Just "MetaBrush" )
+  iconTheme <- GTK.iconThemeGetForDisplay display
+  GTK.iconThemeAddSearchPath iconTheme ( dataPath </> "icons" )
+
+  colours <- getColours cssProvider
+
+  ---------------------------------------------------------
+  -- Create base UI elements
+
+  baseOverlay <- GTK.overlayNew
+  GTK.windowSetChild window ( Just baseOverlay )
+
+  uiGrid <- GTK.gridNew
+  GTK.overlaySetChild baseOverlay ( Just uiGrid )
+
+  toolBar  <- GTK.boxNew   GTK.OrientationVertical   0
+  mainPane <- GTK.panedNew GTK.OrientationHorizontal
+  panelBox <- GTK.boxNew   GTK.OrientationVertical   0
+
+  GTK.gridAttach uiGrid toolBar   0 0 2 1
+  GTK.gridAttach uiGrid mainPane  2 0 1 1
+
+  mainView <- GTK.boxNew GTK.OrientationVertical 0
+
+  GTK.panedSetStartChild mainPane mainView
+  GTK.panedSetEndChild   mainPane panelBox
+
+  viewportGrid <- GTK.gridNew
+
+  ---------------------------------------------------------
+  -- Background
+
+  widgetAddClass uiGrid "bg"
+
+  ---------------------------------------------------------
+  -- Title bar
+
+  titleBar <- GTK.headerBarNew
+
+  GTK.windowSetTitlebar window ( Just titleBar )
+  widgetAddClass titleBar "titleBar"
+
+  logo <- GTK.boxNew GTK.OrientationVertical 0
+  GTK.headerBarPackStart titleBar logo
+
+  GTK.headerBarSetShowTitleButtons titleBar False
+  GTK.headerBarSetDecorationLayout titleBar ( Just "icon:minimize,maximize,close" )
+
+  titleLabel <- GTK.labelNew ( Just "MetaBrush" )
+  GTK.widgetSetHexpand titleLabel True
+  widgetAddClasses titleLabel [ "text", "title", "plain" ]
+  GTK.headerBarSetTitleWidget titleBar ( Just titleLabel )
+
+  --------
+  -- Logo
+
+  widgetAddClass logo "logo"
+
+  logoArea <- GTK.drawingAreaNew
+  GTK.boxAppend logo logoArea
+
+  GTK.widgetSetHexpand logoArea True
+  GTK.widgetSetVexpand logoArea True
+
+  GTK.drawingAreaSetDrawFunc logoArea $ Just \ _ cairoContext _ _ ->
+    void $ Cairo.renderWithContext ( drawLogo colours ) cairoContext
+
+  GTK.widgetQueueDraw logoArea
+
+  ---------------------------------------------------------
+  -- Main viewport
+
+  viewport@( Viewport {..} ) <- createViewport viewportGrid
+
+  -----------------
+  -- Viewport rendering
+
+  -- Update the document render data in a separate thread.
+  _ <- forkIO $ forever do
+      getRenderDoc <- STM.atomically do
+        needsRecomputation <- STM.readTVar recomputeStrokesTVar
+        case needsRecomputation of
+          False -> STM.retry
+          True  -> do
+              mbDocNow <- fmap present <$> activeDocument variables
+              case mbDocNow of
+                Nothing -> pure ( pure . const $ blankRender colours )
+                Just doc -> do
+                  modifiers      <- STM.readTVar modifiersTVar
+                  mbMousePos     <- STM.readTVar mousePosTVar
+                  mbHoldAction   <- STM.readTVar mouseHoldTVar
+                  mbPartialPath  <- STM.readTVar partialPathTVar
+                  mode           <- STM.readTVar modeTVar
+                  showGuides     <- STM.readTVar showGuidesTVar
+                  debug          <- STM.readTVar debugTVar
+                  fitParameters  <- STM.readTVar fitParametersTVar
+                  STM.writeTVar recomputeStrokesTVar False
+                  let
+                    addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) 
+                    addRulers newRender viewportSize = do
+                      newRender viewportSize
+                      renderRuler
+                        colours viewportSize ViewportOrigin viewportSize
+                        mbMousePos mbHoldAction showGuides
+                        doc
+                  pure
+                    ( addRulers <$> getDocumentRender
+                        colours fitParameters mode debug
+                        modifiers mbMousePos mbHoldAction mbPartialPath
+                        doc
+                    )
+      renderDoc <- stToIO getRenderDoc
+      STM.atomically do
+        STM.writeTVar documentRenderTVar renderDoc
+      void do
+        GLib.idleAdd GLib.PRIORITY_HIGH_IDLE do
+          for_
+            [ viewportDrawingArea
+            , rulerCornerDrawingArea
+            , topRulerDrawingArea
+            , leftRulerDrawingArea
+            ]
+            GTK.widgetQueueDraw
+          pure False
+
+  -- Render the document using the latest available draw data.
+  GTK.drawingAreaSetDrawFunc viewportDrawingArea $ Just \ _ cairoContext _ _ -> void $ do
+    viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
+    viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+    -- Get the Cairo instructions for rendering the current document
+    mbDoc <- fmap present <$> STM.atomically ( activeDocument variables )
+    render <- case mbDoc of
+      Nothing -> pure ( blankRender colours )
+      Just _  -> STM.atomically do
+        render <- STM.readTVar documentRenderTVar
+        pure ( render ( viewportWidth, viewportHeight ) )
+    Cairo.renderWithContext render cairoContext
+
+  for_
+    [ ( rulerCornerDrawingArea , RulerCorner )
+    , ( topRulerDrawingArea    , TopRuler    )
+    , ( leftRulerDrawingArea   , LeftRuler   )
+    ]
+    ( \ ( rulerDrawingArea, ruler ) ->
+      GTK.drawingAreaSetDrawFunc rulerDrawingArea $ Just \ _ cairoContext _ _ -> void do
+        viewportWidth  <- GTK.widgetGetAllocatedWidth  viewportDrawingArea
+        viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea
+        width  <- GTK.widgetGetAllocatedWidth  rulerDrawingArea
+        height <- GTK.widgetGetAllocatedHeight rulerDrawingArea
+        mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do
+          mbMousePos   <- STM.readTVar mousePosTVar
+          mbHoldAction <- STM.readTVar mouseHoldTVar
+          showGuides   <- STM.readTVar showGuidesTVar
+          pure do
+            renderRuler
+              colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height )
+              mbMousePos mbHoldAction showGuides
+              doc
+        for_ mbRender \ render ->
+          Cairo.renderWithContext render cairoContext
+    )
+
+  ---------------------------------------------------------
+  -- Tool bar
+
+  _ <- createToolBar variables colours toolBar
+
+  ---------------------------------------------------------
+  -- Info bar
+
+  infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
+
+  menuActions <- createMenuActions
+
+  rec
+
+    ---------------------------------------------------------
+    -- File bar
+
+    fileBar@( FileBar { fileBarBox } ) <-
+      createFileBar
+        colours variables
+        application window windowKeys titleBar titleLabel viewport infoBar
+        menuBar menuActions
+
+    let
+      uiElements :: UIElements
+      uiElements = UIElements {..}
+
+    ------------
+    -- Menu bar
+
+    menuBar <- createMenuBar uiElements variables colours
+
+  GTK.boxAppend mainView fileBarBox
+  GTK.boxAppend mainView viewportGrid
+  GTK.boxAppend mainView infoBarArea
+
+  ---------------------------------------------------------
+  -- Panels
+
+  createPanelBar panelBox
+
+  ---------------------------------------------------------
+  -- Actions
+
+  handleEvents uiElements variables
+
+  ---------------------------------------------------------
+  -- Finishing up
+
+  mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables )
+  updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized
+
+  GTK.widgetShow window
+
+  GTK.widgetSetCanFocus     viewportDrawingArea True
+  GTK.widgetSetFocusOnClick viewportDrawingArea True
+  GTK.widgetSetFocusable    viewportDrawingArea True
+  _ <- GTK.widgetGrabFocus  viewportDrawingArea
+
+  -- need to add the controllers after the callbacks have been registered
+  GTK.widgetAddController window windowKeys
+  GTK.widgetAddController    viewportDrawingArea ( viewportMotionController    viewportEventControllers )
+  GTK.widgetAddController    viewportDrawingArea ( viewportScrollController    viewportEventControllers )
+  GTK.widgetAddController    viewportDrawingArea ( viewportClicksController    viewportEventControllers )
+  GTK.widgetAddController rulerCornerDrawingArea ( viewportMotionController rulerCornerEventControllers )
+  GTK.widgetAddController rulerCornerDrawingArea ( viewportScrollController rulerCornerEventControllers )
+  GTK.widgetAddController rulerCornerDrawingArea ( viewportClicksController rulerCornerEventControllers )
+  GTK.widgetAddController   leftRulerDrawingArea ( viewportMotionController   leftRulerEventControllers )
+  GTK.widgetAddController   leftRulerDrawingArea ( viewportScrollController   leftRulerEventControllers )
+  GTK.widgetAddController   leftRulerDrawingArea ( viewportClicksController   leftRulerEventControllers )
+  GTK.widgetAddController    topRulerDrawingArea ( viewportMotionController    topRulerEventControllers )
+  GTK.widgetAddController    topRulerDrawingArea ( viewportScrollController    topRulerEventControllers )
+  GTK.widgetAddController    topRulerDrawingArea ( viewportClicksController    topRulerEventControllers )

src/app/MetaBrush/Asset/Colours.hs

@@ -1,13 +1,13 @@
 {-# LANGUAGE BlockArguments     #-}
 {-# LANGUAGE DeriveTraversable  #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE OverloadedStrings  #-}
-{-# LANGUAGE RecordWildCards    #-}
 
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
 
 module MetaBrush.Asset.Colours
-  ( ColourRecord(..), ColourType
+  ( ColourRecord(..)
   , Colours, getColours
   )
   where
@@ -42,61 +42,53 @@ data ColourRecord a
   }
   deriving stock ( Show, Functor, Foldable, Traversable )
 
-data ColourType
+newtype ColourName
-  = Colour
+  = ColourName { colourName :: Text }
-  | BackgroundColour
-  deriving stock Show
-
-data ColourName
-  = ColourName
-    { colourName :: !Text
-    , colourType :: !ColourType
-    , stateFlags :: ![ GTK.StateFlags ]
-    }
   deriving stock Show
 
 colourNames :: ColourRecord ColourName
 colourNames = Colours
-  { bg                  = ColourName "bg"                BackgroundColour [ GTK.StateFlagsNormal ]
+  { bg                  = ColourName "bg"
-  , active              = ColourName "active"            BackgroundColour [ GTK.StateFlagsNormal ]
+  , active              = ColourName "active"
-  , close               = ColourName "close"                       Colour [ GTK.StateFlagsNormal ]
+  , close               = ColourName "close"
-  , highlight           = ColourName "highlight"                   Colour [ GTK.StateFlagsNormal ]
+  , highlight           = ColourName "highlight"
-  , cursor              = ColourName "cursor"                      Colour [ GTK.StateFlagsNormal ]
+  , cursor              = ColourName "cursor"
-  , cursorOutline       = ColourName "cursorStroke"                Colour [ GTK.StateFlagsNormal ]
+  , cursorOutline       = ColourName "cursorStroke"
-  , cursorIndicator     = ColourName "cursorIndicator"             Colour [ GTK.StateFlagsNormal ]
+  , cursorIndicator     = ColourName "cursorIndicator"
-  , plain               = ColourName "plain"                       Colour [ GTK.StateFlagsNormal ]
+  , plain               = ColourName "plain"
-  , base                = ColourName "base"                        Colour [ GTK.StateFlagsNormal ]
+  , base                = ColourName "base"
-  , splash              = ColourName "splash"                      Colour [ GTK.StateFlagsNormal ]
+  , splash              = ColourName "splash"
-  , pathPoint           = ColourName "pathPoint"                   Colour [ GTK.StateFlagsNormal ]
+  , pathPoint           = ColourName "pathPoint"
-  , pathPointOutline    = ColourName "pathPointStroke"             Colour [ GTK.StateFlagsNormal ]
+  , pathPointOutline    = ColourName "pathPointStroke"
-  , controlPoint        = ColourName "controlPoint"                Colour [ GTK.StateFlagsNormal ]
+  , controlPoint        = ColourName "controlPoint"
-  , controlPointOutline = ColourName "controlPointStroke"          Colour [ GTK.StateFlagsNormal ]
+  , controlPointOutline = ColourName "controlPointStroke"
-  , path                = ColourName "path"                        Colour [ GTK.StateFlagsNormal ]
+  , path                = ColourName "path"
-  , brush               = ColourName "brush"                       Colour [ GTK.StateFlagsNormal ]
+  , brush               = ColourName "brush"
-  , brushStroke         = ColourName "brushStroke"                 Colour [ GTK.StateFlagsNormal ]
+  , brushStroke         = ColourName "brushStroke"
-  , brushCenter         = ColourName "brushCenter"                 Colour [ GTK.StateFlagsNormal ]
+  , brushCenter         = ColourName "brushCenter"
-  , pointHover          = ColourName "pointHover"                  Colour [ GTK.StateFlagsNormal ]
+  , pointHover          = ColourName "pointHover"
-  , pointSelected       = ColourName "pointSelected"               Colour [ GTK.StateFlagsNormal ]
+  , pointSelected       = ColourName "pointSelected"
-  , viewport            = ColourName "viewport"          BackgroundColour [ GTK.StateFlagsNormal ]
+  , viewport            = ColourName "viewport"
-  , viewportScrollbar   = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ]
+  , viewportScrollbar   = ColourName "viewportScrollbar"
-  , tabScrollbar        = ColourName "tabScrollbar"      BackgroundColour [ GTK.StateFlagsNormal ]
+  , tabScrollbar        = ColourName "tabScrollbar"
-  , rulerBg             = ColourName "ruler"             BackgroundColour [ GTK.StateFlagsNormal ]
+  , rulerBg             = ColourName "ruler"
-  , rulerTick           = ColourName "rulerTick"                   Colour [ GTK.StateFlagsNormal ]
+  , rulerTick           = ColourName "rulerTick"
-  , guide               = ColourName "guide"                       Colour [ GTK.StateFlagsNormal ]
+  , guide               = ColourName "guide"
-  , magnifier           = ColourName "magnifier"                   Colour [ GTK.StateFlagsNormal ]
+  , magnifier           = ColourName "magnifier"
-  , glass               = ColourName "glass"                       Colour [ GTK.StateFlagsNormal ]
+  , glass               = ColourName "glass"
-  , selected            = ColourName "selected"                    Colour [ GTK.StateFlagsNormal ]
+  , selected            = ColourName "selected"
-  , selectedOutline     = ColourName "selectedOutline"             Colour [ GTK.StateFlagsNormal ]
+  , selectedOutline     = ColourName "selectedOutline"
   }
 
 type Colours = ColourRecord GDK.RGBA
 
-getColours :: GTK.WidgetPath -> IO Colours
+getColours
-getColours windowWidgetPath =
+  :: ( GTK.IsStyleProvider styleProvider )
-  for colourNames \ ( ColourName {..} ) -> do
+  => styleProvider -> IO Colours
-    style <- GTK.styleContextNew
+getColours provider =
-    GTK.styleContextSetPath  style windowWidgetPath
+  for colourNames \ ( ColourName { colourName } ) -> do
+    widget <- GTK.fixedNew
+    style <- GTK.widgetGetStyleContext widget
+    GTK.styleContextAddProvider style provider ( fromIntegral GTK.STYLE_PROVIDER_PRIORITY_USER )
     GTK.styleContextAddClass style colourName
-    case colourType of
+    GTK.styleContextGetColor style
-      BackgroundColour -> GTK.styleContextGetBackgroundColor style stateFlags
-      Colour           -> GTK.styleContextGetColor           style stateFlags

src/app/MetaBrush/Context.hs

@@ -3,7 +3,7 @@
 
 module MetaBrush.Context
   ( UIElements(..), Variables(..)
-  , LR(..), Modifier(..), modifierKey, modifierType
+  , LR(..), Modifier(..), modifierKey
   , HoldAction(..), GuideAction(..), PartialPath(..)
   )
   where
@@ -24,9 +24,12 @@ import Data.Map.Strict
 import qualified GI.Cairo.Render as Cairo
   ( Render )
 
--- gi-gtk
+-- gi-gdk
 import qualified GI.Gdk as GDK
 
+-- gi-gio
+import qualified GI.Gio as GIO
+
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
@@ -43,6 +46,8 @@ import Math.Bezier.Cubic.Fit
   ( FitParameters )
 import Math.Vector2D
   ( Point2D )
+import {-# SOURCE #-} MetaBrush.Action
+  ( ActionName )
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Brush
@@ -54,11 +59,9 @@ import MetaBrush.Document.History
 import MetaBrush.Document.Selection
   ( DragMoveSelect )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
-  ( FileBar )
+  ( FileBar, FileBarTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
-import {-# SOURCE #-} MetaBrush.UI.Menu
-  ( Menu, ResourceType(Object) )
 import {-# SOURCE #-} MetaBrush.UI.ToolBar
   ( Tool, Mode )
 import MetaBrush.UI.Viewport
@@ -70,35 +73,38 @@ import MetaBrush.Unique
 
 data UIElements
   = UIElements
-  { window   :: !GTK.Window
+  { application :: !GTK.Application
-  , title    :: !GTK.Label
+  , window      :: !GTK.ApplicationWindow
-  , titleBar :: !GTK.Box
+  , windowKeys  :: !GTK.EventControllerKey
-  , fileBar  :: !FileBar
+  , titleBar    :: !GTK.HeaderBar
-  , viewport :: !Viewport
+  , titleLabel  :: !GTK.Label
-  , infoBar  :: !InfoBar
+  , fileBar     :: !FileBar
-  , menu     :: Menu Object -- needs to be lazy for "recursive do"
+  , viewport    :: !Viewport
-  , colours  :: !Colours
+  , infoBar     :: !InfoBar
+  , menuBar     :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
+  , menuActions :: !( HashMap ActionName GIO.SimpleAction )
+  , colours     :: !Colours
   }
 
 data Variables
   = Variables
   { uniqueSupply         :: !UniqueSupply
-  , recomputeStrokesTVar :: !( STM.TVar Bool                                        )
+  , recomputeStrokesTVar :: !( STM.TVar Bool                                    )
-  , documentRenderTVar   :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () )     )
+  , documentRenderTVar   :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) )
-  , activeDocumentTVar   :: !( STM.TVar ( Maybe Unique )                            )
+  , activeDocumentTVar   :: !( STM.TVar ( Maybe Unique )                        )
-  , openDocumentsTVar    :: !( STM.TVar ( Map Unique DocumentHistory )              )
+  , openDocumentsTVar    :: !( STM.TVar ( Map Unique DocumentHistory )          )
-  , brushesTVar          :: !( STM.TVar ( HashMap Brush Unique )                    )
+  , brushesTVar          :: !( STM.TVar ( HashMap Brush Unique )                )
-  , mousePosTVar         :: !( STM.TVar ( Maybe ( Point2D Double ) )                )
+  , mousePosTVar         :: !( STM.TVar ( Maybe ( Point2D Double ) )            )
-  , mouseHoldTVar        :: !( STM.TVar ( Maybe HoldAction )                        )
+  , mouseHoldTVar        :: !( STM.TVar ( Maybe HoldAction )                    )
-  , modifiersTVar        :: !( STM.TVar ( Set Modifier )                            )
+  , modifiersTVar        :: !( STM.TVar ( Set Modifier )                        )
-  , toolTVar             :: !( STM.TVar Tool                                        )
+  , toolTVar             :: !( STM.TVar Tool                                    )
-  , modeTVar             :: !( STM.TVar Mode                                        )
+  , modeTVar             :: !( STM.TVar Mode                                    )
-  , debugTVar            :: !( STM.TVar Bool                                        )
+  , debugTVar            :: !( STM.TVar Bool                                    )
-  , partialPathTVar      :: !( STM.TVar ( Maybe PartialPath )                       )
+  , partialPathTVar      :: !( STM.TVar ( Maybe PartialPath )                   )
-  , fileBarTabsTVar      :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) )
+  , fileBarTabsTVar      :: !( STM.TVar ( Map Unique FileBarTab )               )
-  , showGuidesTVar       :: !( STM.TVar Bool                                        )
+  , showGuidesTVar       :: !( STM.TVar Bool                                    )
-  , maxHistorySizeTVar   :: !( STM.TVar Int                                         )
+  , maxHistorySizeTVar   :: !( STM.TVar Int                                     )
-  , fitParametersTVar    :: !( STM.TVar FitParameters                               )
+  , fitParametersTVar    :: !( STM.TVar FitParameters                           )
   }
 
 --------------------------------------------------------------------------------
@@ -113,19 +119,14 @@ data Modifier
   deriving stock ( Show, Eq, Ord )
 
 modifierKey :: Word32 -> Maybe Modifier
-modifierKey GDK.KEY_Control_L = Just ( Control L )
+modifierKey n = case fromIntegral n of
-modifierKey GDK.KEY_Control_R = Just ( Control R )
+  GDK.KEY_Control_L -> Just ( Control L )
-modifierKey GDK.KEY_Shift_L   = Just ( Shift L )
+  GDK.KEY_Control_R -> Just ( Control R )
-modifierKey GDK.KEY_Shift_R   = Just ( Shift R )
+  GDK.KEY_Shift_L   -> Just ( Shift L )
-modifierKey GDK.KEY_Alt_L     = Just ( Alt L )
+  GDK.KEY_Shift_R   -> Just ( Shift R )
-modifierKey GDK.KEY_Alt_R     = Just ( Alt R )
+  GDK.KEY_Alt_L     -> Just ( Alt L )
-modifierKey _                 = Nothing
+  GDK.KEY_Alt_R     -> Just ( Alt R )
-
+  _                 -> Nothing
-modifierType :: Modifier -> GDK.ModifierType
-modifierType ( Control _ ) = GDK.ModifierTypeControlMask
-modifierType ( Alt     _ ) = GDK.ModifierTypeMod1Mask
-modifierType ( Shift   _ ) = GDK.ModifierTypeShiftMask
-
 
 data GuideAction
   = CreateGuide !Ruler

src/app/MetaBrush/Document/Update.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
+{-# LANGUAGE MonoLocalBinds    #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE TypeApplications  #-}
 
@@ -38,6 +39,9 @@ import qualified Data.Map.Strict as Map
 import Data.Generics.Product.Fields
   ( field' )
 
+-- gi-gio
+import qualified GI.Gio as GIO
+
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
@@ -65,22 +69,25 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
   ( MaybeT(..) )
 
+-- unordered-containers
+import qualified Data.HashMap.Lazy as HashMap
+  ( lookup )
+
 -- MetaBrush
+import {-# SOURCE #-} MetaBrush.Action
+  ( ActionName(..) )
 import MetaBrush.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.Document
   ( Document(..), DocumentContent(..) )
 import MetaBrush.Document.History
-  ( DocumentHistory(..)
+  ( DocumentHistory(..), atStart, atEnd
   , newFutureStep, affirmPresent
-  , atStart, atEnd
   )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
-  ( removeFileTab )
+  ( FileBarTab(..), removeFileTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( updateInfoBar )
-import MetaBrush.UI.Menu
-  ( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Util
@@ -145,7 +152,7 @@ instance DocumentModification DocModification where
 --
 -- Does nothing if no document is currently active.
 modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO ()
-modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do
+modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables {..} ) f = do
   mbAction <- STM.atomically . runMaybeT $ do
     unique      <- MaybeT ( STM.readTVar activeDocumentTVar )
     oldDoc      <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
@@ -185,25 +192,21 @@ modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f
         uiUpdateAction <- updateUIAction uiElts vars
         pure $ Ap do
           uiUpdateAction
-          GTK.widgetSetSensitive undoMenuItem True
+          for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True  )
-          GTK.widgetSetSensitive redoMenuItem False
+          for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
     pure
       do
         forOf_ docFold modif \ mbNewDoc -> do
           case mbNewDoc of
-            CloseDocument -> removeFileTab vars ( documentUnique oldDoc )
+            CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc )
             _             -> pure ()
         uiUpdateAction
         sequenceAOf_ actionFold modif
   sequenceA_ mbAction
-    where
-      undoMenuItem, redoMenuItem :: GTK.MenuItem
-      undoMenuItem = menuItem $ undo $ menuItemSubmenu $ edit menu
-      redoMenuItem = menuItem $ redo $ menuItemSubmenu $ edit menu
 
 
 updateUIAction :: UIElements -> Variables -> STM ( IO () )
-updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
+updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
   mbDocHist <- activeDocument vars
   let
     mbDoc :: Maybe Document
@@ -214,18 +217,18 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
     mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
     pure ( (,) <$> mbActiveTab <*> mbDoc )
   pure do
-    updateTitle window title mbTitleText
+    updateTitle window titleLabel mbTitleText
     updateInfoBar viewportDrawingArea infoBar vars mbDoc
-    for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do
+    for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do
-      GTK.buttonSetLabel activeTabLabel ( displayName activeDoc )
+      GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc )
-      GTK.widgetQueueDraw activeTab
+      GTK.widgetQueueDraw fileBarTab
-    STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
+      GTK.widgetQueueDraw fileBarTabCloseArea
-    for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
+      updateHistoryState uiElts mbDocHist
-      GTK.widgetQueueDraw drawingArea
+      STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
 
-updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
+updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
-updateTitle window title mbTitleText = do
+updateTitle window titleLabel mbTitleText = do
-  GTK.labelSetText   title  titleText
+  GTK.labelSetText titleLabel titleText
   GTK.setWindowTitle window titleText
   where
     titleText :: Text
@@ -241,18 +244,12 @@ updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO ()
 updateHistoryState ( UIElements {..} ) mbHist =
   case mbHist of
     Nothing -> do
-      GTK.widgetSetSensitive undoMenuItem False
+      for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
-      GTK.widgetSetSensitive redoMenuItem False
+      for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
     Just hist -> do
       if atStart hist
-      then GTK.widgetSetSensitive undoMenuItem False
+      then for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
-      else GTK.widgetSetSensitive undoMenuItem True
+      else for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True  )
       if atEnd hist
-      then GTK.widgetSetSensitive redoMenuItem False
+      then for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
-      else GTK.widgetSetSensitive redoMenuItem True
+      else for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True  )
-  where
-    editMenu :: EditMenu Object
-    editMenu = menuItemSubmenu ( edit menu )
-    undoMenuItem, redoMenuItem :: GTK.MenuItem
-    undoMenuItem = menuItem $ undo $ editMenu
-    redoMenuItem = menuItem $ redo $ editMenu

src/app/MetaBrush/Event.hs

@@ -12,6 +12,10 @@ import Control.Monad
   ( void )
 import Data.Foldable
   ( for_ )
+import Data.Int
+  ( Int32 )
+import Data.Word
+  ( Word32 )
 
 -- gi-gdk
 import qualified GI.Gdk as GDK
@@ -19,6 +23,10 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
+-- stm
+import qualified Control.Concurrent.STM.TVar as STM
+  ( readTVarIO )
+
 -- MetaBrush
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
@@ -32,7 +40,7 @@ import MetaBrush.Action
 import MetaBrush.Context
   ( UIElements(..), Variables(..) )
 import MetaBrush.UI.Viewport
-  ( Viewport(..), Ruler(..) )
+  ( Viewport(..), ViewportEventControllers(..), Ruler(..) )
 
 --------------------------------------------------------------------------------
 
@@ -40,72 +48,74 @@ handleEvents :: UIElements -> Variables -> IO ()
 handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
 
   -- Mouse events
-  afterWidgetMouseEvent    viewportDrawingArea ViewportOrigin
+  afterWidgetMouseEvent    viewportEventControllers ViewportOrigin
-  afterWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner )
+  afterWidgetMouseEvent rulerCornerEventControllers ( RulerOrigin RulerCorner )
-  afterWidgetMouseEvent   leftRulerDrawingArea ( RulerOrigin LeftRuler   )
+  afterWidgetMouseEvent   leftRulerEventControllers ( RulerOrigin LeftRuler   )
-  afterWidgetMouseEvent    topRulerDrawingArea ( RulerOrigin TopRuler    )
+  afterWidgetMouseEvent    topRulerEventControllers ( RulerOrigin TopRuler    )
 
   -- Keyboard events
-  void $ GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
+  void $ GTK.onEventControllerKeyKeyPressed  windowKeys
-  void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
+    ( handleKeyboardPressEvent   elts vars )
+  void $ GTK.onEventControllerKeyKeyReleased windowKeys
+    ( handleKeyboardReleaseEvent elts vars )
 
   -- Window quit
-  void $ GTK.onWidgetDestroy window ( quitEverything window )
+  void $ GTK.onApplicationQueryEnd application ( quitEverything application window )
 
     where
-      afterWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO ()
+      afterWidgetMouseEvent :: ViewportEventControllers -> ActionOrigin -> IO ()
-      afterWidgetMouseEvent drawingArea eventOrigin = do
+      afterWidgetMouseEvent ( ViewportEventControllers {..}) eventOrigin = do
-        void $ GTK.afterWidgetMotionNotifyEvent  drawingArea ( handleMotionEvent        elts vars eventOrigin )
+        void $ GTK.afterEventControllerMotionMotion  viewportMotionController
-        void $ GTK.afterWidgetScrollEvent        drawingArea ( handleScrollEvent        elts vars eventOrigin )
+          ( handleMotionEvent        elts vars eventOrigin )
-        void $ GTK.afterWidgetButtonPressEvent   drawingArea ( handleMouseButtonEvent   elts vars eventOrigin )
+        void $ GTK.afterEventControllerScrollScroll  viewportScrollController
-        void $ GTK.afterWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin )
+          ( handleScrollEvent        elts vars )
+        void $ GTK.afterGestureClickPressed          viewportClicksController
+          ( handleMouseButtonEvent   elts vars eventOrigin viewportClicksController )
+        void $ GTK.afterGestureClickReleased         viewportClicksController
+          ( handleMouseButtonRelease elts vars eventOrigin viewportClicksController )
 
 --------------------------------------------------------------------------------
 -- Mouse events.
 
-handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool
+handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () )
-handleMotionEvent elts vars eventOrigin eventMotion = do
+handleMotionEvent elts vars eventOrigin x y = do
-  x <- GDK.getEventMotionX eventMotion
-  y <- GDK.getEventMotionY eventMotion
   mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
   handleAction elts vars ( MouseMove mousePos )
-  pure True
 
-handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool
+handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool )
-handleScrollEvent elts vars eventOrigin scrollEvent = do
+handleScrollEvent elts vars dx dy = do
-  dx <- GDK.getEventScrollDeltaX scrollEvent
+  mbMousePos <- STM.readTVarIO ( mousePosTVar vars )
-  dy <- GDK.getEventScrollDeltaY scrollEvent
+  handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) )
-  x  <- GDK.getEventScrollX scrollEvent
-  y  <- GDK.getEventScrollY scrollEvent
-  mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
-  handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) )
   pure False
 
-handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
+handleMouseButtonEvent
-handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do
+  :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
-  ty <- GDK.getEventButtonType mouseClickEvent
+  -> ( Int32 -> Double -> Double -> IO () )
+handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars eventOrigin gestureClick nbClicks x y = do
   let
     mbClick :: Maybe MouseClickType
-    mbClick = case ty of
+    mbClick
-      GDK.EventTypeButtonPress  -> Just SingleClick
+      | nbClicks >= 2
-      GDK.EventType2buttonPress -> Just DoubleClick
+      = Just DoubleClick
-      _                         -> Nothing
+      | nbClicks == 1
+      = Just SingleClick
+      | otherwise
+      = Nothing
   for_ mbClick \ click -> do
-    button <- GDK.getEventButtonButton mouseClickEvent
+    _ <- GTK.widgetGrabFocus viewportDrawingArea
-    x  <- GDK.getEventButtonX mouseClickEvent
+    button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
-    y  <- GDK.getEventButtonY mouseClickEvent
+    --        ^^^^^ use button number 1 if no button number is reported (button == 0)
     mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
     handleAction elts vars ( MouseClick eventOrigin click button mousePos )
-  pure False
 
-handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool
+handleMouseButtonRelease
-handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do
+  :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
-  button <- GDK.getEventButtonButton mouseReleaseEvent
+  -> ( Int32 -> Double -> Double -> IO () )
-  x <- GDK.getEventButtonX mouseReleaseEvent
+handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do
-  y <- GDK.getEventButtonY mouseReleaseEvent
+  button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
+  --        ^^^^^ same as above
   mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
   handleAction elts vars ( MouseRelease button mousePos )
-  pure False
 
 adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
 adjustMousePosition   _                   ViewportOrigin        pt            = pure pt
@@ -125,14 +135,16 @@ adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
 --------------------------------------------------------------------------------
 -- Keyboard events.
 
-handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
+handleKeyboardPressEvent
-handleKeyboardPressEvent elts vars evt = do
+  :: UIElements -> Variables
-  keyCode <- GDK.getEventKeyKeyval evt
+  -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO Bool )
-  handleAction elts vars ( KeyboardPress keyCode )
+handleKeyboardPressEvent elts vars keyVal _ _ = do
+  handleAction elts vars ( KeyboardPress keyVal )
   pure False -- allow the default handler to run
 
-handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
+
-handleKeyboardReleaseEvent elts vars evt = do
+handleKeyboardReleaseEvent
-  keyCode <- GDK.getEventKeyKeyval evt
+  :: UIElements -> Variables
-  handleAction elts vars ( KeyboardRelease keyCode )
+  -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO () )
-  pure False -- allow the default handler to run
+handleKeyboardReleaseEvent elts vars keyVal _ _ =
+  handleAction elts vars ( KeyboardRelease keyVal )

src/app/MetaBrush/UI/FileBar.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.UI.FileBar
-  ( FileBar(..)
+  ( FileBar(..), FileBarTab(..)
   , createFileBar, newFileTab, removeFileTab
   , TabLocation(..)
   )
@@ -15,11 +15,9 @@ module MetaBrush.UI.FileBar
 
 -- base
 import Control.Monad
-  ( join, unless, void )
+  ( join, void )
 import Data.Foldable
   ( for_, sequenceA_ )
-import Data.Int
-  ( Int32 )
 import Data.Traversable
   ( for )
 
@@ -31,13 +29,12 @@ import qualified Data.Map.Strict as Map
 import qualified GI.Cairo.Render.Connector as Cairo
   ( renderWithContext )
 
+-- gi-gio
+import qualified GI.Gio as GIO
+
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- haskell-gi-base
-import qualified Data.GI.Base.GValue as GI
-import qualified Data.GI.Base.GType  as GI
-
 -- stm
 import qualified Control.Concurrent.STM      as STM
   ( atomically )
@@ -48,9 +45,13 @@ import qualified Control.Concurrent.STM.TVar as STM
 import Control.Monad.Trans.Reader
   ( runReaderT )
 
+-- unordered-containers
+import Data.HashMap.Lazy
+  ( HashMap )
+
 -- MetaBrush
-import MetaBrush.Action
+import {-# SOURCE #-} MetaBrush.Action
-  ( SwitchTo(..), Close(..), handleAction )
+  ( ActionName, SwitchFromTo(..), Close(..), handleAction )
 import MetaBrush.Asset.CloseTabButton
   ( drawCloseTabButton )
 import MetaBrush.Asset.Colours
@@ -67,16 +68,12 @@ import MetaBrush.Document.Update
   ( updateUIAction )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
-import {-# SOURCE #-} MetaBrush.UI.Menu
-  ( Menu, ResourceType(Object) )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Unique
   ( Unique, freshUnique, uniqueText )
 import MetaBrush.Util
-  ( widgetAddClass, widgetAddClasses
+  ( widgetAddClass, widgetAddClasses )
-  , Exists(..)
-  )
 
 --------------------------------------------------------------------------------
 
@@ -84,7 +81,14 @@ data FileBar
   = FileBar
   { fileBarBox  :: !GTK.Box
   , fileTabsBox :: !GTK.Box
-  , fileBarPhantomRadioButton :: !GTK.RadioButton
+  , fileBarPhantomToggleButton :: !GTK.ToggleButton
+  }
+
+data FileBarTab
+  = FileBarTab
+  { fileBarTab          :: !GTK.Box
+  , fileBarTabButton    :: !GTK.ToggleButton
+  , fileBarTabCloseArea :: !GTK.DrawingArea
   }
 
 data TabLocation
@@ -93,14 +97,12 @@ data TabLocation
   deriving stock Show
 
 newFileTab
-  :: Bool
+  :: UIElements
-  -> UIElements
   -> Variables
   -> Maybe DocumentHistory
   -> TabLocation
   -> IO ()
 newFileTab
-  initialStage
   uiElts@( UIElements { fileBar = FileBar {..}, .. } )
   vars@( Variables {..} )
   mbDocHist
@@ -116,18 +118,19 @@ newFileTab
         pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
 
     let
-      newUnique :: Unique
+      thisTabDocUnique :: Unique
-      newUnique = documentUnique ( present newDocHist )
+      thisTabDocUnique = documentUnique ( present newDocHist )
 
+    -- TODO: make the file tab an EditableLabel
     -- File tab elements.
-    pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist )
+    pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist )
-    GTK.toggleButtonSetMode pgButton False -- don't display radio indicator
+    GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
     closeFileButton <- GTK.buttonNew
     closeFileArea <- GTK.drawingAreaNew
-    GTK.containerAdd closeFileButton closeFileArea
+    GTK.buttonSetChild closeFileButton ( Just closeFileArea )
 
-    void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do
+    GTK.drawingAreaSetDrawFunc closeFileArea $ Just \ _ cairoContext _ _ -> void do
-      mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar
+      mbTabDoc <- fmap present . Map.lookup thisTabDocUnique <$> STM.readTVarIO openDocumentsTVar
       let
         unsaved :: Bool
         unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc
@@ -137,104 +140,115 @@ newFileTab
     -- Create box for file tab elements.
     tab <- GTK.boxNew GTK.OrientationHorizontal 0
     widgetAddClasses tab [ "fileBarTab" ]
-    GTK.boxPackStart fileTabsBox tab             False False 0
+    GTK.boxAppend tab pgButton
-    GTK.boxPackStart tab         pgButton        True  True  0
+    GTK.boxAppend tab closeFileButton
-    GTK.boxPackStart tab         closeFileButton False False 0
     widgetAddClasses pgButton        [ "fileBarTabButton" ]
     widgetAddClasses closeFileButton [ "fileBarCloseButton" ]
-    GTK.widgetShowAll tab
 
-    -- We've placed the new tab at the end. Now rearrange it if necessary.
+    -- Place the new tab in the correct position within the file bar.
     case newTabLoc of
-      LastTab -> pure ()
+      LastTab ->
+        GTK.boxAppend fileTabsBox tab
       AfterCurrentTab -> do
         mbActiveTab <- fmap join $ STM.atomically do
           mbUnique <- STM.readTVar activeDocumentTVar
           for mbUnique \ docUnique -> do
             Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
-        for_ mbActiveTab \ ( activeTab, _ ) -> do
+        case mbActiveTab of
-          old_gValue <- GI.newGValue GI.gtypeInt
+          Just ( FileBarTab { fileBarTab = activeTab } )
-          GTK.containerChildGetProperty fileTabsBox activeTab "position" old_gValue
+            -> GTK.boxInsertChildAfter fileTabsBox tab ( Just activeTab )
-          new_gValue <- GI.toGValue @Int32 =<< ( +1 ) <$> GI.fromGValue @Int32 old_gValue
+          _ -> GTK.boxAppend fileTabsBox tab
-          GTK.containerChildSetProperty fileTabsBox       tab "position" new_gValue
-
-    -- Ensure consistency of hover/selection state between the two elements in the tab.
-    for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do
-      void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True
-        pure False
-      void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do
-        flags <- GTK.widgetGetStateFlags tab
-        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True
-        pure False
 
+    let
+      fileBarTab :: FileBarTab
+      fileBarTab =
+        FileBarTab
+          { fileBarTab          = tab
+          , fileBarTabButton    = pgButton
+          , fileBarTabCloseArea = closeFileArea
+          }
     -- Update the state: switch to this new document.
     uiUpdateAction <- STM.atomically do
-      STM.modifyTVar' openDocumentsTVar  ( Map.insert newUnique newDocHist )
+      STM.modifyTVar' openDocumentsTVar  ( Map.insert thisTabDocUnique newDocHist )
-      STM.modifyTVar' fileBarTabsTVar    ( Map.insert newUnique ( tab, pgButton ) )
+      STM.modifyTVar' fileBarTabsTVar    ( Map.insert thisTabDocUnique fileBarTab )
-      -- don't update UI if we are just creating file tabs for the first time
+      STM.writeTVar   activeDocumentTVar ( Just thisTabDocUnique )
-      -- (we don't have access to the full menu at that point, so this would otherwise loop)
+      updateUIAction uiElts vars
-      if initialStage
-      then pure ( pure () )
-      else do
-        STM.writeTVar activeDocumentTVar ( Just newUnique )
-        updateUIAction uiElts vars 
     uiUpdateAction
 
-    void $ GTK.onButtonClicked pgButton do
+    void $ GTK.afterToggleButtonToggled pgButton do
-      isActive <- GTK.toggleButtonGetActive pgButton
+      nowActive <- GTK.toggleButtonGetActive pgButton
-      flags    <- GTK.widgetGetStateFlags tab
+      flags <- GTK.widgetGetStateFlags tab
-      if isActive
+      mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar
+      if nowActive
       then do
-        GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True
+        -- If changing tabs, switch document.
-        handleAction uiElts vars ( SwitchTo newUnique )
+        -- This will untoggle the previously active tab
+        -- ('onToggleButtonToggled' will run this handler).
+        handleAction uiElts vars ( SwitchFromTo mbPrevActiveDocUnique thisTabDocUnique )
+        GTK.widgetSetStateFlags tab
+          ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
+          True
       else do
-        GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
+        -- Otherwise, ensure the tab hasn't been toggled off on its own
-      GTK.widgetQueueDraw closeFileArea
+        -- (clicking on an already selected tab shouldn't do anything, not untoggle the tab).
+        mbNewActiveDocUnique <- STM.readTVarIO activeDocumentTVar
+        case mbNewActiveDocUnique of
+          -- Clicking on already selected document: don't allow the tab to be toggled off.
+          Just unique | unique == thisTabDocUnique
+            -> do
+              GTK.toggleButtonSetActive pgButton True
+              GTK.widgetSetStateFlags tab
+                ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags )
+                True
+          -- Otherwise: leave it toggled off.
+          _ -> GTK.widgetSetStateFlags tab
+                ( filter (/= GTK.StateFlagsActive) flags )
+                True
+
+    GTK.toggleButtonSetActive pgButton False
+    GTK.toggleButtonSetActive pgButton True
 
     void $ GTK.onButtonClicked closeFileButton do
       GTK.widgetQueueDraw closeFileArea
-      handleAction uiElts vars ( CloseThis newUnique )
+      handleAction uiElts vars ( CloseThis thisTabDocUnique )
-
-    -- Activate the button, unless we are creating buttons for the first time,
-    -- in which case we shouldn't activate it as we don't have a menu yet,
-    -- so we wouldn't be able to handle the associated action.
-    unless initialStage ( GTK.toggleButtonSetActive pgButton True )
 
 -- | Create a file bar: tabs allowing selection of the active document.
 --
 -- Updates the active document when buttons are clicked.
 createFileBar
   :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
+  -> GTK.Application -> GTK.ApplicationWindow -> GTK.EventControllerKey
+  -> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar
+  -> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction
   -> IO FileBar
 createFileBar
   colours
   vars@( Variables { openDocumentsTVar } )
-  window titleBar title viewport infoBar menu
+  application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
   = do
 
     -- Create file bar: box containing scrollable tabs, and a "+" button after it.
     fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0
     widgetAddClass fileBarBox "fileBar"
 
-    fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment )
+    fileTabsScroll <- GTK.scrolledWindowNew
     GTK.scrolledWindowSetPolicy           fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
     GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True
+    GTK.widgetSetHexpand fileTabsScroll True
 
     newFileButton <- GTK.buttonNewWithLabel "+"
     widgetAddClasses newFileButton [ "newFileButton" ]
 
-    GTK.boxPackEnd   fileBarBox newFileButton   False False 0
+    GTK.boxAppend fileBarBox fileTabsScroll
-    GTK.boxPackStart fileBarBox fileTabsScroll  True  True  0
+    GTK.boxAppend fileBarBox newFileButton
+    GTK.widgetSetHalign newFileButton GTK.AlignEnd
 
     fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
-    GTK.containerAdd fileTabsScroll fileTabsBox
+    GTK.scrolledWindowSetChild fileTabsScroll ( Just fileTabsBox )
     widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ]
 
-    -- Phantom radio button for when no page is selected (e.g. no documents opened yet).
+    -- Phantom toggle button for when no page is selected (e.g. no documents opened yet).
-    fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton )
+    fileBarPhantomToggleButton <- GTK.toggleButtonNew
 
     let
       fileBar :: FileBar
@@ -244,13 +258,13 @@ createFileBar
 
     documents <- STM.readTVarIO openDocumentsTVar
     for_ documents \ doc ->
-      newFileTab True
+      newFileTab
         uiElements vars
         ( Just doc )
         LastTab
 
     void $ GTK.onButtonClicked newFileButton do
-      newFileTab False
+      newFileTab
         uiElements vars
         Nothing
         LastTab
@@ -258,15 +272,18 @@ createFileBar
     pure fileBar
 
 -- | Close a document: remove the corresponding file tab from the file bar.
-removeFileTab :: Variables -> Unique -> IO ()
+removeFileTab :: UIElements -> Variables -> Unique -> IO ()
-removeFileTab ( Variables {..} ) docUnique = do
+removeFileTab
+  ( UIElements { fileBar = FileBar { fileTabsBox } } )
+  ( Variables {..} )
+  docUnique = do
 
-  cleanupAction <- STM.atomically do
+    cleanupAction <- STM.atomically do
-    -- Remove the tab.
+      -- Remove the tab.
-    mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
+      mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
-    for mbTab \ ( tab, _ ) -> do
+      for mbTab \ ( FileBarTab { fileBarTab = tab } ) -> do
-      STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
+        STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
-      STM.modifyTVar' fileBarTabsTVar   ( Map.delete docUnique )
+        STM.modifyTVar' fileBarTabsTVar   ( Map.delete docUnique )
-      pure ( GTK.widgetDestroy tab )
+        pure ( GTK.boxRemove fileTabsBox tab )
-
+  
-  sequenceA_ cleanupAction
+    sequenceA_ cleanupAction

src/app/MetaBrush/UI/FileBar.hs-boot

@@ -1,9 +1,6 @@
-{-# LANGUAGE DataKinds #-}
-
 module MetaBrush.UI.FileBar
-  ( FileBar(..)
+  ( FileBar(..), FileBarTab(..), TabLocation(..)
-  , createFileBar, newFileTab, removeFileTab
+  , removeFileTab
-  , TabLocation(..)
   )
   where
 
@@ -11,18 +8,8 @@ module MetaBrush.UI.FileBar
 import qualified GI.Gtk as GTK
 
 -- MetaBrush
-import MetaBrush.Asset.Colours
-  ( Colours )
 import {-# SOURCE #-} MetaBrush.Context
   ( Variables, UIElements )
-import MetaBrush.Document.History
-  ( DocumentHistory )
-import {-# SOURCE #-} MetaBrush.UI.InfoBar
-  ( InfoBar )
-import {-# SOURCE #-} MetaBrush.UI.Menu
-  ( Menu, ResourceType(Object) )
-import MetaBrush.UI.Viewport
-  ( Viewport )
 import MetaBrush.Unique
   ( Unique )
 
@@ -32,7 +19,14 @@ data FileBar
   = FileBar
   { fileBarBox  :: !GTK.Box
   , fileTabsBox :: !GTK.Box
-  , fileBarPhantomRadioButton :: !GTK.RadioButton
+  , fileBarPhantomToggleButton :: !GTK.ToggleButton
+  }
+
+data FileBarTab
+  = FileBarTab
+  { fileBarTab          :: !GTK.Box
+  , fileBarTabButton    :: !GTK.ToggleButton
+  , fileBarTabCloseArea :: !GTK.DrawingArea
   }
 
 data TabLocation
@@ -41,15 +35,4 @@ data TabLocation
 
 instance Show TabLocation
 
-createFileBar
+removeFileTab :: UIElements -> Variables -> Unique -> IO ()
-  :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
-  -> IO FileBar
-
-newFileTab
-  :: Bool
-  -> UIElements -> Variables
-  -> Maybe DocumentHistory -> TabLocation
-  -> IO ()
-
-removeFileTab :: Variables -> Unique -> IO ()

src/app/MetaBrush/UI/InfoBar.hs

@@ -78,6 +78,7 @@ createInfoBar :: Colours -> IO InfoBar
 createInfoBar colours = do
   infoBarArea       <- GTK.boxNew GTK.OrientationHorizontal 0
   widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ]
+  GTK.widgetSetHalign infoBarArea GTK.AlignEnd
 
   zoomBox        <- GTK.boxNew GTK.OrientationHorizontal 0
   cursorPosBox   <- GTK.boxNew GTK.OrientationHorizontal 0
@@ -85,7 +86,7 @@ createInfoBar colours = do
   botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
 
   for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do
-    GTK.boxPackEnd infoBarArea box False False 0
+    GTK.boxPrepend infoBarArea box
     widgetAddClass box "infoBarBox"
 
   -------------
@@ -94,11 +95,11 @@ createInfoBar colours = do
   magnifierArea <- GTK.drawingAreaNew
   zoomText <- GTK.labelNew ( Just na )
 
-  GTK.boxPackStart zoomBox magnifierArea True True 0
+  GTK.boxAppend zoomBox magnifierArea
-  GTK.boxPackStart zoomBox zoomText      True True 0
+  GTK.boxAppend zoomBox zoomText
 
-  void $ GTK.onWidgetDraw magnifierArea \ ctx ->
+  GTK.drawingAreaSetDrawFunc magnifierArea $ Just \ _ cairoContext _ _ ->
-    ( `Cairo.renderWithContext` ctx ) $ do
+    void $ ( `Cairo.renderWithContext` cairoContext ) do
       Cairo.scale 0.9 0.9
       Cairo.translate 14 10
       drawMagnifier colours
@@ -109,11 +110,11 @@ createInfoBar colours = do
   cursorPosArea <- GTK.drawingAreaNew
   cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
-  GTK.boxPackStart cursorPosBox cursorPosArea False False 0
+  GTK.boxAppend cursorPosBox cursorPosArea
-  GTK.boxPackStart cursorPosBox cursorPosText False False 0
+  GTK.boxAppend cursorPosBox cursorPosText
 
-  void $ GTK.onWidgetDraw cursorPosArea \ ctx ->
+  GTK.drawingAreaSetDrawFunc cursorPosArea $ Just \ _ cairoContext _ _ ->
-    ( `Cairo.renderWithContext` ctx ) $ do
+    void $ ( `Cairo.renderWithContext` cairoContext ) do
       Cairo.scale 0.75 0.75
       Cairo.translate 9.5 7
       drawCursorIcon colours
@@ -124,12 +125,11 @@ createInfoBar colours = do
   topLeftPosArea <- GTK.drawingAreaNew
   topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
-  GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0
+  GTK.boxAppend topLeftPosBox topLeftPosArea
-  GTK.boxPackStart topLeftPosBox topLeftPosText False False 0
+  GTK.boxAppend topLeftPosBox topLeftPosText
 
-  void $ GTK.onWidgetDraw topLeftPosArea
+  GTK.drawingAreaSetDrawFunc topLeftPosArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawTopLeftCornerRect colours ) cairoContext
-      ( drawTopLeftCornerRect colours )
 
   -------------------------
   -- Bottom right position
@@ -137,11 +137,11 @@ createInfoBar colours = do
   botRightPosArea <- GTK.drawingAreaNew
   botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
 
-  GTK.boxPackStart botRightPosBox botRightPosArea False False 0
+  GTK.boxAppend botRightPosBox botRightPosArea
-  GTK.boxPackStart botRightPosBox botRightPosText False False 0
+  GTK.boxAppend botRightPosBox botRightPosText
 
-  void $ GTK.onWidgetDraw botRightPosArea \ ctx ->
+  GTK.drawingAreaSetDrawFunc botRightPosArea $ Just \ _ cairoContext _ _ ->
-    ( `Cairo.renderWithContext` ctx ) $ do
+    void $ ( `Cairo.renderWithContext` cairoContext ) do
       Cairo.scale -1 -1
       Cairo.translate -40 -40
       drawTopLeftCornerRect colours
@@ -195,4 +195,4 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl
       replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0'
 
 na :: IsString a => a
-na = "      n/a"
+na = "      n/a"

src/app/MetaBrush/UI/InfoBar.hs-boot

@@ -1,5 +1,5 @@
 module MetaBrush.UI.InfoBar
-  ( InfoBar(..), createInfoBar, updateInfoBar )
+  ( InfoBar(..), updateInfoBar )
   where
 
 -- gi-gtk
@@ -22,6 +22,5 @@ data InfoBar
   , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label
   }
 
-createInfoBar :: Colours -> IO InfoBar
+updateInfoBar
-
+  :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()
-updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO ()

src/app/MetaBrush/UI/Menu.hs

@@ -1,52 +1,29 @@
-{-# LANGUAGE BlockArguments         #-}
+{-# LANGUAGE BlockArguments      #-}
-{-# LANGUAGE ConstraintKinds        #-}
+{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE DataKinds              #-}
+{-# LANGUAGE DeriveGeneric       #-}
-{-# LANGUAGE DeriveGeneric          #-}
+{-# LANGUAGE DerivingStrategies  #-}
-{-# LANGUAGE DerivingStrategies     #-}
+{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE FlexibleContexts       #-}
+{-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE FlexibleInstances      #-}
+{-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE LambdaCase             #-}
+{-# LANGUAGE PolyKinds           #-}
-{-# LANGUAGE NamedFieldPuns         #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings      #-}
+{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE PolyKinds              #-}
-{-# LANGUAGE RecordWildCards        #-}
-{-# LANGUAGE ScopedTypeVariables    #-}
-{-# LANGUAGE TypeApplications       #-}
-{-# LANGUAGE TypeFamilies           #-}
 
-module MetaBrush.UI.Menu
+module MetaBrush.UI.Menu where
-  ( newMenuBar
-  , Menu(..)
-  , FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..)
-  , ResourceType(..)
-  , MenuItem(..)
-  , createMenuBar
-  )
-  where
 
 -- base
 import Control.Monad
-  ( void, unless )
+  ( void )
 import Data.Foldable
-  ( for_ )
+  ( for_, traverse_ )
-import Data.Kind
-  ( Type )
-import Data.Word
-  ( Word32 )
-import GHC.Generics
-  ( Generic )
-
--- generic-lens
-import Data.Generics.Product.Constraints
-  ( HasConstraints(constraints) )
 
 -- gi-cairo-connector
 import qualified GI.Cairo.Render.Connector as Cairo
   ( renderWithContext )
 
--- gi-gdk
+-- gi-gio
-import qualified GI.Gdk as GDK
+import qualified GI.Gio as GIO
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
@@ -54,22 +31,33 @@ import qualified GI.Gtk as GTK
 -- text
 import Data.Text
   ( Text )
+import qualified Data.Text as Text
+  ( unpack )
 
 -- transformers
 import Control.Monad.IO.Class
-  ( MonadIO(liftIO) )
+  ( MonadIO(..) )
+
+-- unordered-containers
+import Data.HashMap.Strict
+  ( HashMap )
+import qualified Data.HashMap.Strict as HashMap
+  ( lookup, traverseWithKey )
+import Data.HashSet
+  ( HashSet )
+import qualified Data.HashSet as HashSet
+  ( fromList, toMap )
 
 -- MetaBrush
-import {-# SOURCE #-} MetaBrush.Action
+import MetaBrush.Action
+  hiding ( save, saveAs )
 import MetaBrush.Context
-  ( UIElements(..), Variables(..)
+  ( UIElements(..), Variables(..) )
-  , LR(..), Modifier(..), modifierType
-  )
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Asset.WindowIcons
   ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
-import {-# SOURCE #-} MetaBrush.UI.FileBar
+import MetaBrush.UI.FileBar
   ( TabLocation(..) )
 import MetaBrush.Util
   ( widgetAddClass, widgetAddClasses )
@@ -77,289 +65,226 @@ import MetaBrush.Util
 --------------------------------------------------------------------------------
 -- Types for describing menu items.
 
-data ResourceType
+data MenuItem where
-  = Description
+  SubmenuDescription ::
-  | Object
+    { submenuLabel   :: !( Maybe Text )
+    , submenuItems   :: ![ MenuItem ]
+    } -> MenuItem
+  MenuItemDescription :: HandleAction action =>
+    { menuItemLabel  :: !Text
+    , menuItemAction :: !( Maybe ActionName, action )
+    , menuItemAccel  :: !( Maybe Text )
+    } -> MenuItem
+  Section ::
+    { sectionName  :: !( Maybe Text )
+    , sectionItems :: [ MenuItem ]
+    } -> MenuItem
 
-data family   MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
+menuActionNames :: HashSet ActionName
-data instance MenuItem action submenu Description 
+menuActionNames = HashSet.fromList
-  = MenuItemDescription
+  -- file menu
-    { menuItemLabel      :: !Text
+  [ WinAction "newFile"
-    , menuItemClasses    :: ![ Text ]
+  , WinAction "openFile"
-    , menuItemAction     :: !action
+  , WinAction "openFolder"
-    , menuItemAccel      :: !( Maybe ( Word32, [ Modifier ] ) )
+  , WinAction "save"
-    , submenuDescription :: !( submenu Description )
+  , WinAction "saveAs"
-    }
+  , WinAction "closeActive"
-data instance MenuItem action submenu Object
+  , WinAction "quit"
-  = MenuItem
+  -- edit menu
-  { menuItem        :: !GTK.MenuItem
+  , WinAction "undo"
-  , menuItemSubmenu :: !( submenu Object )
+  , WinAction "redo"
-  }
+  , WinAction "cut"
+  , WinAction "copy"
+  , WinAction "paste"
+  , WinAction "duplicate"
+  , WinAction "delete"
+  -- view menu
+  , WinAction "toggleGuides"
+  -- about menu
+  , AppAction "about"
+  ]
 
-data family   Separator ( r :: ResourceType )
+createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction )
-data instance Separator Description
+createMenuActions =
-  = SeparatorDescription
+  HashMap.traverseWithKey
-    { separatorClasses :: ![ Text ] }
+    ( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing )
-data instance Separator Object
+    ( HashSet.toMap menuActionNames )
-  = Separator
-  { separatorItem :: !GTK.MenuItem }
-
-data NoSubresource ( k :: ResourceType ) = NoSubresource
 
 --------------------------------------------------------------------------------
 -- Menu used in MetaBrush.
 
--- Types.
+menuDescription :: [ MenuItem ]
+menuDescription =
+  [ SubmenuDescription ( Just "File" ) fileMenuDescription
+  , SubmenuDescription ( Just "Edit" ) editMenuDescription
+  , SubmenuDescription ( Just "View" ) viewMenuDescription
+  , SubmenuDescription ( Just "Help" ) helpMenuDescription
+  ]
 
-data Menu ( rt :: ResourceType )
+fileMenuDescription :: [ MenuItem ]
-  = Menu
+fileMenuDescription =
-  { file :: !( MenuItem () FileMenu rt )
+  [ MenuItemDescription "New"         ( Just $ WinAction "newFile"    , ( NewFile    AfterCurrentTab ) ) ( Just "<Control>n"        )
-  , edit :: !( MenuItem () EditMenu rt )
+  , MenuItemDescription "Open file"   ( Just $ WinAction "openFile"   , ( OpenFile   AfterCurrentTab ) ) ( Just "<Control>o"        )
-  , view :: !( MenuItem () ViewMenu rt )
+  , MenuItemDescription "Open folder" ( Just $ WinAction "openFolder" , ( OpenFolder AfterCurrentTab ) ) ( Just "<Control><Shift>o" )
-  , help :: !( MenuItem () HelpMenu rt )
+  , MenuItemDescription "Save"        ( Just $ WinAction "save"       , Save                           ) ( Just "<Control>s"        )
-  }
+  , MenuItemDescription "Save as"     ( Just $ WinAction "saveAs"     , SaveAs                         ) ( Just "<Control><Shift>s" )
-  deriving stock Generic
+  , MenuItemDescription "Close"       ( Just $ WinAction "closeActive", CloseActive                    ) ( Just "<Control>w"        )
+  , MenuItemDescription "Quit"        ( Just $ WinAction "quit"       , Quit                           ) ( Just "<Control>q"        )
+  ]
 
-data FileMenu ( rt :: ResourceType )
+editMenuDescription :: [ MenuItem ]
-  = FileMenu
+editMenuDescription =
-  { new        :: !( MenuItem NewFile    NoSubresource rt )
+  [ Section Nothing
-  , openFile   :: !( MenuItem OpenFile   NoSubresource rt )
+    [ MenuItemDescription "Undo"        ( Just $ WinAction "undo", Undo )      ( Just "<Control>z" )
-  , openFolder :: !( MenuItem OpenFolder NoSubresource rt )
+    , MenuItemDescription "Redo"        ( Just $ WinAction "redo", Redo )      ( Just "<Control>y" )
-  , save       :: !( MenuItem Save       NoSubresource rt )
+    ]
-  , saveAs     :: !( MenuItem SaveAs     NoSubresource rt )
+  , Section Nothing
-  , close      :: !( MenuItem Close      NoSubresource rt )
+    [ MenuItemDescription "Cut"         ( Just $ WinAction "cut"      , Cut       ) ( Just "<Control>x" )
-  , quit       :: !( MenuItem Quit       NoSubresource rt )
+    , MenuItemDescription "Copy"        ( Just $ WinAction "copy"     , Copy      ) ( Just "<Control>c" )
-  }
+    , MenuItemDescription "Paste"       ( Just $ WinAction "paste"    , Paste     ) ( Just "<Control>v" )
-  deriving stock Generic
+    , MenuItemDescription "Duplicate"   ( Just $ WinAction "duplicate", Duplicate ) ( Just "<Control>d" )
+    , MenuItemDescription "Delete"      ( Just $ WinAction "delete"   , Delete    ) ( Just "Delete"  )
+    ]
+  , Section Nothing
+    [ MenuItemDescription "Preferences" ( Nothing, () ) ( Just "<Control><Shift>p" )
+    ]
+  ]
 
-data EditMenu ( rt :: ResourceType )
+viewMenuDescription :: [ MenuItem ]
-  = EditMenu
+viewMenuDescription =
-  { undo           :: !( MenuItem Undo           NoSubresource rt )
+  [ Section Nothing
-  , redo           :: !( MenuItem Redo           NoSubresource rt )
+    [ MenuItemDescription "Navigator"      ( Nothing, () ) Nothing
-  , editSep1       :: !( Separator rt )
+    , MenuItemDescription "History"        ( Nothing, () ) ( Just "<Control>h" )
-  , cut            :: !( MenuItem Cut            NoSubresource rt )
+    ]
-  , copy           :: !( MenuItem Copy           NoSubresource rt )
+  , Section Nothing
-  , paste          :: !( MenuItem Paste          NoSubresource rt )
+    [ MenuItemDescription "Strokes"        ( Nothing, () ) Nothing
-  , duplicate      :: !( MenuItem Duplicate      NoSubresource rt )
+    , MenuItemDescription "Brushes"        ( Nothing, () ) Nothing
-  , delete         :: !( MenuItem Delete         NoSubresource rt )
+    , MenuItemDescription "Metaparameters" ( Nothing, () ) Nothing
-  , editSep2       :: !( Separator rt )
+    ]
-  , preferences    :: !( MenuItem ()             NoSubresource rt )
+  , Section Nothing
-  }
+    [ MenuItemDescription "Transform"      ( Nothing, () ) Nothing
-  deriving stock Generic
+    ]
+  , Section Nothing
+    [ MenuItemDescription "Toggle guides"  ( Just $ WinAction "toggleGuides", ToggleGuides ) ( Just "g" )
+    ]
+  ]
 
-data ViewMenu ( rt :: ResourceType )
+helpMenuDescription :: [ MenuItem ]
-  = ViewMenu
+helpMenuDescription =
-  { navigator      :: !( MenuItem () NoSubresource rt )
+  [ MenuItemDescription "About MetaBrush" ( Just $ AppAction "about", About ) ( Just "<Ctrl>question" )
-  , history        :: !( MenuItem () NoSubresource rt )
+  ]
-  , viewSep1       :: !( Separator rt )
-  , strokes        :: !( MenuItem () NoSubresource rt )
-  , brushes        :: !( MenuItem () NoSubresource rt )
-  , metaparameters :: !( MenuItem () NoSubresource rt )
-  , viewSep2       :: !( Separator rt )
-  , transform      :: !( MenuItem () NoSubresource rt )
-  , viewSep3       :: !( Separator rt )
-  , toggleGuides   :: !( MenuItem ToggleGuides NoSubresource rt )
-  }
-  deriving stock Generic
-
-data HelpMenu ( rt :: ResourceType )
-  = HelpMenu
-  { about :: !( MenuItem About NoSubresource rt ) }
-  deriving stock Generic
-
--- Descriptions.
-
-menuDescription :: Menu Description
-menuDescription
-  = Menu
-  { file = MenuItemDescription "File" [ "menuItem", "file" ] () Nothing fileMenuDescription
-  , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] () Nothing editMenuDescription
-  , view = MenuItemDescription "View" [ "menuItem", "view" ] () Nothing viewMenuDescription
-  , help = MenuItemDescription "Help" [ "menuItem", "help" ] () Nothing helpMenuDescription
-  }
-
-fileMenuDescription :: FileMenu Description
-fileMenuDescription
-  = FileMenu
-  { new        = MenuItemDescription "New"         [ "submenuItem" ] ( NewFile    AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
-  , openFile   = MenuItemDescription "Open file"   [ "submenuItem" ] ( OpenFile   AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
-  , openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift L ] ) ) NoSubresource
-  , save       = MenuItemDescription "Save"        [ "submenuItem" ] Save                           ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
-  , saveAs     = MenuItemDescription "Save as"     [ "submenuItem" ] SaveAs                         ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
-  , close      = MenuItemDescription "Close"       [ "submenuItem" ] CloseActive                    ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
-  , quit       = MenuItemDescription "Quit"        [ "submenuItem" ] Quit                           ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
-  }
-
-editMenuDescription :: EditMenu Description
-editMenuDescription
-  = EditMenu
-  { undo           = MenuItemDescription  "Undo"            [ "submenuItem" ] Undo           ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
-  , redo           = MenuItemDescription  "Redo"            [ "submenuItem" ] Redo           ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
-  , editSep1       = SeparatorDescription                   [ "submenuSeparator" ]
-  , cut            = MenuItemDescription  "Cut"             [ "submenuItem" ] Cut       ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
-  , copy           = MenuItemDescription  "Copy"            [ "submenuItem" ] Copy      ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
-  , paste          = MenuItemDescription  "Paste"           [ "submenuItem" ] Paste     ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
-  , duplicate      = MenuItemDescription  "Duplicate"       [ "submenuItem" ] Duplicate ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
-  , delete         = MenuItemDescription  "Delete"          [ "submenuItem" ] Delete    ( Just ( GDK.KEY_Delete, [] ) )       NoSubresource
-  , editSep2       = SeparatorDescription                   [ "submenuSeparator" ]
-  , preferences    = MenuItemDescription  "Preferences"     [ "submenuItem" ] ()        ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource
-  }
-
-viewMenuDescription :: ViewMenu Description
-viewMenuDescription
-  = ViewMenu
-  { navigator      = MenuItemDescription  "Navigator"      [ "submenuItem" ] () Nothing NoSubresource
-  , history        = MenuItemDescription  "History"        [ "submenuItem" ] () ( Just ( GDK.KEY_H, [ Control L ] ) ) NoSubresource
-  , viewSep1       = SeparatorDescription                  [ "submenuSeparator" ]
-  , strokes        = MenuItemDescription  "Strokes"        [ "submenuItem" ] () Nothing NoSubresource
-  , brushes        = MenuItemDescription  "Brushes"        [ "submenuItem" ] () Nothing NoSubresource
-  , metaparameters = MenuItemDescription  "Metaparameters" [ "submenuItem" ] () Nothing NoSubresource
-  , viewSep2       = SeparatorDescription                  [ "submenuSeparator" ]
-  , transform      = MenuItemDescription  "Transform"      [ "submenuItem" ] () Nothing NoSubresource
-  , viewSep3       = SeparatorDescription                  [ "submenuSeparator" ]
-  , toggleGuides   = MenuItemDescription  "Hide guides"    [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource
-  }
-
-helpMenuDescription :: HelpMenu Description
-helpMenuDescription
-  = HelpMenu
-  { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] About ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource }
 
 --------------------------------------------------------------------------------
--- Creating a GTK menu bar from a menu description.
+-- Creating a GTK popover menu bar from a menu description.
 
-newMenuItem
+makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
-  :: ( MonadIO m, HandleAction action )
+makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
-  => UIElements
+  SubmenuDescription
-  -> Variables
+    { submenuLabel
-  -> GTK.AccelGroup
+    , submenuItems
-  -> MenuItem action submenu Description
+    } -> do
-  -> m GTK.MenuItem
+      submenu <- GIO.menuNew
-newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do
+      makeMenu uiElts vars submenu submenuItems
-  menuItem <- GTK.menuItemNewWithLabel menuItemLabel
+      GIO.menuAppendSubmenu menu submenuLabel submenu
-  for_ menuItemAccel \ ( key, modifiers ) -> do
+  MenuItemDescription
-    GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
+    { menuItemLabel
-    GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel"
+    , menuItemAction = ( mbActionName, actionData )
-  unless ( null menuItemClasses ) do
+    , menuItemAccel
-    widgetAddClasses menuItem menuItemClasses
+    } -> do
-  void $ GTK.onMenuItemActivate menuItem
+      for_ mbActionName \ actionName -> do
-    ( handleAction uiElts vars menuItemAction )
+        let
-  pure menuItem
+          simpleName :: Text
-
+          simpleName = actionSimpleName actionName
-class CreateMenuItem desc res | desc -> res, res -> desc where
+        case HashMap.lookup actionName menuActions of
-  createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res
+          Nothing ->
-instance {-# OVERLAPPING #-}
+            error
-  HandleAction action
+              ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
-  =>  CreateMenuItem
+                ": missing action " <> show actionName
-        ( MenuItem action NoSubresource Description )
+              )
-        ( MenuItem action NoSubresource Object )
+          Just menuItemAction -> do
-    where
+            _ <- GIO.onSimpleActionActivate menuItemAction
-  createMenuItem uiElts vars accelGroup attachToParent menuItemDescription = do
+                    ( \ _ -> handleAction uiElts vars actionData )
-    menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription 
+            GIO.actionMapAddAction window menuItemAction
-    attachToParent menuItem
+        for_ menuItemAccel \ accelText -> do
-    pure 
+          actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing
-      MenuItem
+          GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText]
-      { menuItem        = menuItem
+      menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
-      , menuItemSubmenu = NoSubresource
+      GIO.menuAppendItem menu menuItem
-      }
+  Section
-instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
+    { sectionName
-      => CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object )
+    , sectionItems
-      where
+    } -> do
-  createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
+      section <- GIO.menuNew
-    menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription
+      makeMenu uiElts vars section sectionItems
-    submenu <- GTK.menuNew
+      GIO.menuAppendSection menu sectionName section
-    GTK.menuSetAccelGroup submenu ( Just accelGroup )
-    submenuItems <-
-      constraints @CreateMenuItem
-        ( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend submenu ) )
-        submenuDescription
-    GTK.menuItemSetSubmenu menuItem ( Just submenu )
-    attachToParent menuItem
-    pure
-      MenuItem 
-      { menuItem        = menuItem
-      , menuItemSubmenu = submenuItems
-      }
-instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
-  createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do
-    separator <- GTK.separatorMenuItemNew
-    unless ( null separatorClasses ) do
-      widgetAddClasses separator separatorClasses
-    sep <- liftIO ( GTK.unsafeCastTo GTK.MenuItem separator )
-    attachToParent sep
-    pure ( Separator { separatorItem = sep } )
-
-newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
-newMenuBar uiElts vars accelGroup = do
-  menuBar <- GTK.menuBarNew
-  menu <-
-    constraints @CreateMenuItem
-      ( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend menuBar ) )
-      menuDescription
-  pure ( menuBar, menu )
 
 --------------------------------------------------------------------------------
 -- Creating the menu bar from its declarative specification.
 
--- | Add the menu bar to the given box (title bar box).
+createMenu :: MonadIO m => UIElements -> Variables -> m GIO.Menu
-createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
+createMenu uiElts vars = do
-createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
+  menu <- GIO.menuNew
-  accelGroup <- GTK.accelGroupNew
+  makeMenu uiElts vars menu menuDescription
-  GTK.windowAddAccelGroup window accelGroup
+  pure menu
-  ( menuBar, menu ) <- newMenuBar uiElts vars accelGroup
-  widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
-  GTK.boxPackStart titleBar menuBar False False 0
 
+-- | Add the menu bar to the given box (title bar box).
+createMenuBar :: MonadIO m => UIElements -> Variables -> Colours -> m GTK.PopoverMenuBar
+createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colours = do
+  --accelGroup <- GTK.accelGroupNew
+  --GTK.windowAddAccelGroup window accelGroup
+  menu <- createMenu uiElts vars
+  menuBar <- GTK.popoverMenuBarNewFromModel ( Just menu )
+  widgetAddClasses menuBar [ "menu", "text", "plain" ]
+  GTK.headerBarPackStart titleBar menuBar
+  
   -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items.
   -- Activating a menu somehow sets the "hover" setting,
   -- so instead we use the "selected" setting for actual hover highlighting.
-  topLevelMenuItems <- GTK.containerGetChildren menuBar
+  -- GTK4 FIXME
-  for_ topLevelMenuItems \ topLevelMenuItem -> do
+  --topLevelMenuItems <- GTK.containerGetChildren menuBar
-    void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
+  --for_ topLevelMenuItems \ topLevelMenuItem -> do
-      flags <- GTK.widgetGetStateFlags topLevelMenuItem
+  --  void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
-      GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
+  --    flags <- GTK.widgetGetStateFlags topLevelMenuItem
-      pure False
+  --    GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
-    void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
+  --    pure False
-      flags <- GTK.widgetGetStateFlags topLevelMenuItem
+  --  void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
-      GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
+  --    flags <- GTK.widgetGetStateFlags topLevelMenuItem
-      pure False
+  --    GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
+  --    pure False
 
   windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
-  widgetAddClasses windowIcons [ "windowIcon" ]
+  widgetAddClasses windowIcons [ "windowIcons" ]
-  GTK.boxPackEnd titleBar windowIcons False False 0
+  GTK.headerBarPackEnd titleBar windowIcons
 
-  minimiseButton   <- GTK.buttonNew
+  minimiseButton <- GTK.buttonNew
-  fullscreenButton <- GTK.buttonNew
+  maximiseButton <- GTK.buttonNew
-  closeButton      <- GTK.buttonNew
+  closeButton    <- GTK.buttonNew
 
-  GTK.boxPackStart windowIcons   minimiseButton True True 0
+  GTK.boxAppend windowIcons minimiseButton
-  GTK.boxPackStart windowIcons fullscreenButton True True 0
+  GTK.boxAppend windowIcons maximiseButton
-  GTK.boxPackStart windowIcons      closeButton True True 0
+  GTK.boxAppend windowIcons    closeButton
 
-  minimiseArea   <- GTK.drawingAreaNew
+  minimiseArea <- GTK.drawingAreaNew
-  fullscreenArea <- GTK.drawingAreaNew
+  maximiseArea <- GTK.drawingAreaNew
-  closeArea      <- GTK.drawingAreaNew
+  closeArea    <- GTK.drawingAreaNew
 
-  GTK.containerAdd   minimiseButton   minimiseArea
+  GTK.buttonSetChild minimiseButton ( Just minimiseArea )
-  GTK.containerAdd fullscreenButton fullscreenArea
+  GTK.buttonSetChild maximiseButton ( Just maximiseArea )
-  GTK.containerAdd      closeButton      closeArea
+  GTK.buttonSetChild    closeButton ( Just    closeArea )
 
-  void $ GTK.onWidgetDraw minimiseArea
+  GTK.drawingAreaSetDrawFunc minimiseArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawMinimise colours ) cairoContext
-      ( drawMinimise colours )
 
-  void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do
+  GTK.drawingAreaSetDrawFunc maximiseArea $ Just \ _ cairoContext _ _ -> do
-    Just gdkWindow <- GTK.widgetGetWindow window
+    isMaximised <- GTK.getWindowMaximized window
-    windowState <- GDK.windowGetState gdkWindow
+    if isMaximised
-    if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState
+    then void $ Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
-    then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
+    else void $ Cairo.renderWithContext ( drawMaximise    colours ) cairoContext
-    else Cairo.renderWithContext ( drawMaximise    colours ) cairoContext
 
-  void $ GTK.onWidgetDraw closeArea
+  GTK.drawingAreaSetDrawFunc closeArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawClose colours ) cairoContext
-      ( drawClose colours )
 
-  for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
+  for_ [ minimiseButton, maximiseButton, closeButton ] \ button -> do
     widgetAddClass button "windowIcon"
 
   widgetAddClass closeButton "closeWindowIcon"
@@ -367,18 +292,17 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
   ---------------------------------------------------------
   -- Actions
 
-  _ <- GTK.onButtonClicked closeButton    ( quitEverything window )
+  _ <- GTK.onButtonClicked closeButton    ( quitEverything application window )
-  _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
+  _ <- GTK.onButtonClicked minimiseButton ( GTK.windowMinimize window )
-  _ <- GTK.onButtonClicked fullscreenButton do
+  _ <- GTK.onButtonClicked maximiseButton do
-    Just gdkWindow <- GTK.widgetGetWindow window
+    isMaximised <- GTK.getWindowMaximized window
-    windowState <- GDK.windowGetState gdkWindow
+    if isMaximised
-    if GDK.WindowStateFullscreen `elem` windowState
+    then GTK.windowUnmaximize window
-    then   GTK.windowUnfullscreen window
+    else GTK.windowMaximize   window
-    else
+    GTK.widgetQueueDraw maximiseArea
-      if GDK.WindowStateMaximized `elem` windowState
-      then GTK.windowUnmaximize   window
-      else GTK.windowMaximize     window
 
   ---------------------------------------------------------
 
-  pure menu
+  GTK.applicationSetMenubar application ( Just menu )
+
+  pure menuBar

src/app/MetaBrush/UI/Menu.hs-boot

@@ -1,53 +0,0 @@
-{-# LANGUAGE DataKinds       #-}
-{-# LANGUAGE PolyKinds       #-}
-{-# LANGUAGE RoleAnnotations #-}
-{-# LANGUAGE TypeFamilies    #-}
-
-module MetaBrush.UI.Menu
-  ( ResourceType(..), MenuItem
-  , Menu
-  , FileMenu, EditMenu, ViewMenu, HelpMenu
-  , newMenuBar, createMenuBar
-  ) where
-
--- base
-import Data.Kind
-  ( Type )
-
--- gi-gtk
-import qualified GI.Gtk as GTK
-
--- transformers
-import Control.Monad.IO.Class
-  ( MonadIO )
-import MetaBrush.Asset.Colours
-  ( Colours )
-import {-# SOURCE #-} MetaBrush.Context
-  ( UIElements, Variables )
-
---------------------------------------------------------------------------------
-
-data ResourceType
-  = Description
-  | Object
-
-data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
-
-data Menu ( rt :: ResourceType )
-type role Menu nominal
-
-data FileMenu ( rt :: ResourceType )
-type role FileMenu nominal
-
-data EditMenu ( rt :: ResourceType )
-type role EditMenu nominal
-
-data ViewMenu ( rt :: ResourceType )
-type role ViewMenu nominal
-
-data HelpMenu ( rt :: ResourceType )
-type role HelpMenu nominal
-
-newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
-
-createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )

src/app/MetaBrush/UI/Panels.hs

@@ -27,7 +27,8 @@ createPanelBar panelBox = do
   widgetAddClass panelBox "panels"
 
   pane1 <- GTK.panedNew GTK.OrientationVertical
-  GTK.boxPackStart panelBox pane1 True True 0
+  GTK.widgetSetVexpand pane1 True
+  GTK.boxAppend panelBox pane1
 
   panels1 <- GTK.notebookNew
   panels2 <- GTK.notebookNew
@@ -35,8 +36,8 @@ createPanelBar panelBox = do
   GTK.notebookSetGroupName panels1 ( Just "Panel" )
   GTK.notebookSetGroupName panels2 ( Just "Panel" )
 
-  GTK.panedPack1 pane1 panels1 True True
+  GTK.panedSetStartChild pane1 panels1
-  GTK.panedPack2 pane1 panels2 True True
+  GTK.panedSetEndChild   pane1 panels2
 
   strokesPanel   <- GTK.boxNew GTK.OrientationVertical 0
   brushesPanel   <- GTK.boxNew GTK.OrientationVertical 0
@@ -75,9 +76,9 @@ createPanelBar panelBox = do
   transformContent <- GTK.labelNew ( Just "Transform tab content..." )
   historyContent   <- GTK.labelNew ( Just "History tab content..." )
 
-  GTK.boxPackStart   strokesPanel   strokesContent True True 0
+  GTK.boxAppend   strokesPanel   strokesContent
-  GTK.boxPackStart   brushesPanel   brushesContent True True 0
+  GTK.boxAppend   brushesPanel   brushesContent
-  GTK.boxPackStart transformPanel transformContent True True 0
+  GTK.boxAppend transformPanel transformContent
-  GTK.boxPackStart   historyPanel   historyContent True True 0
+  GTK.boxAppend   historyPanel   historyContent
 
   pure ()

src/app/MetaBrush/UI/ToolBar.hs

@@ -11,8 +11,10 @@ module MetaBrush.UI.ToolBar
   where
 
 -- base
+import Control.Arrow
+  ( second )
 import Control.Monad
-  ( void )
+  ( void, when )
 import Data.Foldable
   ( for_ )
 
@@ -56,8 +58,9 @@ data Mode
 
 data ToolBar
   = ToolBar
-  { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
+  { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
-  , debugTool :: !GTK.ToggleButton  }
+      :: !GTK.ToggleButton 
+  }
 
 createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
 createToolBar ( Variables {..} ) colours toolBar = do
@@ -67,30 +70,35 @@ createToolBar ( Variables {..} ) colours toolBar = do
   GTK.widgetSetValign  toolBar GTK.AlignStart
   GTK.widgetSetVexpand toolBar True
 
-  selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton )
+  selectionTool <- GTK.toggleButtonNew
-  penTool       <- GTK.radioButtonNewFromWidget ( Just selectionTool )
+  penTool       <- GTK.toggleButtonNew
-
+  GTK.toggleButtonSetGroup penTool ( Just selectionTool )
-  _ <- GTK.onButtonClicked selectionTool $ STM.atomically do
+  makeToggleGroup $
-    STM.writeTVar toolTVar Selection
+    fmap
-  _ <- GTK.onButtonClicked penTool $ STM.atomically do
+      ( second \ toolVal -> STM.atomically do
-    STM.writeTVar toolTVar Pen
+        STM.writeTVar toolTVar toolVal
+        STM.writeTVar partialPathTVar Nothing
+        STM.writeTVar recomputeStrokesTVar True
+      )
+      [ ( selectionTool, Selection ), ( penTool, Pen ) ]
+  GTK.toggleButtonSetActive selectionTool True
 
   toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
 
-  pathTool  <- GTK.radioButtonNew ( [] @GTK.RadioButton )
+  pathTool  <- GTK.toggleButtonNew
-  brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool )
+  brushTool <- GTK.toggleButtonNew
-  metaTool  <- GTK.radioButtonNewFromWidget ( Just pathTool )
+  metaTool  <- GTK.toggleButtonNew
-
+  GTK.toggleButtonSetGroup brushTool ( Just pathTool )
-  _ <- GTK.onButtonClicked pathTool $ STM.atomically do
+  GTK.toggleButtonSetGroup metaTool  ( Just pathTool )
-    STM.writeTVar modeTVar PathMode
+  makeToggleGroup $
-    STM.writeTVar recomputeStrokesTVar True
+    fmap
-  _ <- GTK.onButtonClicked brushTool $ STM.atomically do
+      ( second \ modeVal -> STM.atomically do
-    STM.writeTVar modeTVar BrushMode
+        STM.writeTVar modeTVar modeVal
-    STM.writeTVar recomputeStrokesTVar True
+        STM.writeTVar partialPathTVar Nothing
-  _ <- GTK.onButtonClicked metaTool $ STM.atomically do
+        STM.writeTVar recomputeStrokesTVar True
-    STM.writeTVar modeTVar MetaMode
+      )
-    STM.writeTVar recomputeStrokesTVar True
+      [ ( pathTool, PathMode ), ( brushTool, BrushMode ), ( metaTool, MetaMode ) ]
-
+  GTK.toggleButtonSetActive pathTool True
 
   toolSep2 <- GTK.boxNew GTK.OrientationVertical 0
 
@@ -100,20 +108,22 @@ createToolBar ( Variables {..} ) colours toolBar = do
     clicked <- GTK.toggleButtonGetActive debugTool
     STM.atomically do
       STM.writeTVar debugTVar clicked
+      STM.writeTVar partialPathTVar Nothing
       STM.writeTVar recomputeStrokesTVar True
 
-  GTK.boxPackStart toolBar selectionTool True True 0
+  GTK.boxAppend toolBar selectionTool
-  GTK.boxPackStart toolBar       penTool True True 0
+  GTK.boxAppend toolBar       penTool
-  GTK.boxPackStart toolBar      toolSep1 True True 0
+  GTK.boxAppend toolBar      toolSep1
-  GTK.boxPackStart toolBar      pathTool True True 0
+  GTK.boxAppend toolBar      pathTool
-  GTK.boxPackStart toolBar     brushTool True True 0
+  GTK.boxAppend toolBar     brushTool
-  GTK.boxPackStart toolBar      metaTool True True 0
+  GTK.boxAppend toolBar      metaTool
-  GTK.boxPackStart toolBar      toolSep2 True True 0
+  GTK.boxAppend toolBar      toolSep2
-  GTK.boxPackStart toolBar     debugTool True True 0
+  GTK.boxAppend toolBar     debugTool
 
-  for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do
+  for_ [ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool ] \ tool -> do
-    GTK.toggleButtonSetMode tool False -- don't display radio indicator
     widgetAddClass tool "toolItem"
+    GTK.widgetSetFocusOnClick tool False
+    GTK.widgetSetFocusable    tool False
 
   widgetAddClass debugTool "toolItem"
 
@@ -134,35 +144,37 @@ createToolBar ( Variables {..} ) colours toolBar = do
   metaToolArea      <- GTK.drawingAreaNew
   debugToolArea     <- GTK.drawingAreaNew
 
-  GTK.containerAdd selectionTool selectionToolArea
+  GTK.buttonSetChild selectionTool ( Just selectionToolArea )
-  GTK.containerAdd       penTool       penToolArea
+  GTK.buttonSetChild       penTool ( Just       penToolArea )
-  GTK.containerAdd      pathTool      pathToolArea
+  GTK.buttonSetChild      pathTool ( Just      pathToolArea )
-  GTK.containerAdd     brushTool     brushToolArea
+  GTK.buttonSetChild     brushTool ( Just     brushToolArea )
-  GTK.containerAdd      metaTool      metaToolArea
+  GTK.buttonSetChild      metaTool ( Just      metaToolArea )
-  GTK.containerAdd     debugTool     debugToolArea
+  GTK.buttonSetChild     debugTool ( Just     debugToolArea )
 
-  void $ GTK.onWidgetDraw selectionToolArea
+  GTK.drawingAreaSetDrawFunc selectionToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawCursorIcon colours ) cairoContext
-      ( drawCursorIcon colours )
 
-  void $ GTK.onWidgetDraw penToolArea
+  GTK.drawingAreaSetDrawFunc penToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawPen colours ) cairoContext
-      ( drawPen colours )
 
-  void $ GTK.onWidgetDraw pathToolArea
+  GTK.drawingAreaSetDrawFunc pathToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawPath colours ) cairoContext
-      ( drawPath colours )
 
-  void $ GTK.onWidgetDraw brushToolArea
+  GTK.drawingAreaSetDrawFunc brushToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawBrush colours ) cairoContext
-      ( drawBrush colours )
 
-  void $ GTK.onWidgetDraw metaToolArea
+  GTK.drawingAreaSetDrawFunc metaToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawMeta colours ) cairoContext
-      ( drawMeta colours )
 
-  void $ GTK.onWidgetDraw debugToolArea
+  GTK.drawingAreaSetDrawFunc debugToolArea $ Just \ _ cairoContext _ _ ->
-    $ Cairo.renderWithContext
+    void $ Cairo.renderWithContext ( drawBug colours ) cairoContext
-      ( drawBug colours )
 
   pure ( ToolBar {..} )
+
+makeToggleGroup :: [ ( GTK.ToggleButton, IO () ) ] -> IO ()
+makeToggleGroup buttons =
+  for_ buttons \ ( button, action ) ->
+    GTK.afterToggleButtonToggled button do
+      isActive <- GTK.toggleButtonGetActive button
+      GTK.widgetSetSensitive button ( not isActive )
+      when isActive action

src/app/MetaBrush/UI/ToolBar.hs-boot

@@ -24,6 +24,6 @@ instance Show Mode
 
 data ToolBar
   = ToolBar
-  { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton
+  { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
-  , debugTool :: !GTK.ToggleButton 
+      :: !GTK.ToggleButton 
   }

src/app/MetaBrush/UI/Viewport.hs

@@ -4,7 +4,8 @@
 {-# LANGUAGE RecordWildCards    #-}
 
 module MetaBrush.UI.Viewport
-  ( Viewport(..), createViewport
+  ( Viewport(..), ViewportEventControllers(..)
+  , createViewport
   , Ruler(..)
   )
   where
@@ -13,9 +14,6 @@ module MetaBrush.UI.Viewport
 import Data.Foldable
   ( for_ )
 
--- gi-gdk
-import qualified GI.Gdk as GDK
-
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
@@ -25,6 +23,13 @@ import MetaBrush.Util
 
 --------------------------------------------------------------------------------
 
+data ViewportEventControllers
+  = ViewportEventControllers
+  { viewportMotionController :: !GTK.EventControllerMotion
+  , viewportScrollController :: !GTK.EventControllerScroll
+  , viewportClicksController :: !GTK.GestureClick
+  }
+
 data Viewport
   = Viewport
   {    viewportDrawingArea
@@ -32,6 +37,11 @@ data Viewport
   ,   leftRulerDrawingArea
   ,    topRulerDrawingArea
     :: !GTK.DrawingArea
+  ,    viewportEventControllers
+  , rulerCornerEventControllers
+  ,   leftRulerEventControllers
+  ,    topRulerEventControllers
+    :: !ViewportEventControllers
   }
 
 createViewport :: GTK.Grid -> IO Viewport
@@ -56,9 +66,9 @@ createViewport viewportGrid = do
   leftRuler   <- GTK.boxNew GTK.OrientationVertical   0
   topRuler    <- GTK.boxNew GTK.OrientationHorizontal 0
 
-  GTK.containerAdd rvRulerCorner rulerCorner
+  GTK.revealerSetChild rvRulerCorner ( Just rulerCorner )
-  GTK.containerAdd rvLeftRuler   leftRuler
+  GTK.revealerSetChild rvLeftRuler   ( Just leftRuler   )
-  GTK.containerAdd rvTopRuler    topRuler
+  GTK.revealerSetChild rvTopRuler    ( Just topRuler    )
 
   widgetAddClasses rulerCorner [ "ruler", "rulerCorner" ]
   widgetAddClasses leftRuler   [ "ruler", "leftRuler" ]
@@ -73,13 +83,13 @@ createViewport viewportGrid = do
   GTK.revealerSetTransitionType rvTopRuler    GTK.RevealerTransitionTypeSlideUp
 
   rulerCornerDrawingArea <- GTK.drawingAreaNew
-  GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0
+  GTK.boxAppend rulerCorner rulerCornerDrawingArea
 
   leftRulerDrawingArea   <- GTK.drawingAreaNew
-  GTK.boxPackStart leftRuler   leftRulerDrawingArea   True True 0
+  GTK.boxAppend leftRuler   leftRulerDrawingArea
   
   topRulerDrawingArea    <- GTK.drawingAreaNew
-  GTK.boxPackStart topRuler    topRulerDrawingArea    True True 0
+  GTK.boxAppend topRuler    topRulerDrawingArea
 
   GTK.widgetSetHexpand rulerCorner     False
   GTK.widgetSetVexpand rulerCorner     False
@@ -91,14 +101,49 @@ createViewport viewportGrid = do
   GTK.widgetSetVexpand viewportOverlay True
 
   viewportDrawingArea <- GTK.drawingAreaNew
-  GTK.setContainerChild viewportOverlay viewportDrawingArea
+  GTK.overlaySetChild viewportOverlay ( Just viewportDrawingArea )
 
-  for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do
+  -- Adding mouse event controllers to all drawing areas.
-    GTK.widgetAddEvents drawingArea
+  viewportMotion <- GTK.eventControllerMotionNew
-      [ GDK.EventMaskPointerMotionMask
+  viewportScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
-      , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask
+  viewportClicks <- GTK.gestureClickNew
-      , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask
+  GTK.gestureSingleSetButton viewportClicks 0
-      ]
+  let
+    viewportEventControllers :: ViewportEventControllers
+    viewportEventControllers =
+      ViewportEventControllers viewportMotion viewportScroll viewportClicks
+
+  rulerCornerMotion <- GTK.eventControllerMotionNew
+  rulerCornerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
+  rulerCornerClicks <- GTK.gestureClickNew
+  GTK.gestureSingleSetButton rulerCornerClicks 0
+  let
+    rulerCornerEventControllers :: ViewportEventControllers
+    rulerCornerEventControllers =
+      ViewportEventControllers rulerCornerMotion rulerCornerScroll rulerCornerClicks
+
+  leftRulerMotion <- GTK.eventControllerMotionNew
+  leftRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
+  leftRulerClicks <- GTK.gestureClickNew
+  GTK.gestureSingleSetButton leftRulerClicks 0
+  let
+    leftRulerEventControllers :: ViewportEventControllers
+    leftRulerEventControllers =
+      ViewportEventControllers leftRulerMotion leftRulerScroll leftRulerClicks
+
+  topRulerMotion <- GTK.eventControllerMotionNew
+  topRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
+  topRulerClicks <- GTK.gestureClickNew
+  GTK.gestureSingleSetButton topRulerClicks 0
+  let
+    topRulerEventControllers :: ViewportEventControllers
+    topRulerEventControllers =
+      ViewportEventControllers topRulerMotion topRulerScroll topRulerClicks
+
+  for_ [ viewportDrawingArea, rulerCornerDrawingArea,  topRulerDrawingArea ]
+    ( `GTK.widgetSetHexpand` True )
+  for_ [ viewportDrawingArea, rulerCornerDrawingArea, leftRulerDrawingArea ]
+    ( `GTK.widgetSetVexpand` True )
 
   {-
   -----------------

src/app/MetaBrush/Util.hs

@@ -43,10 +43,10 @@ import Control.Monad.Trans.Maybe
 
 withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b
 withRGBA rgba f = do
-  r <- GDK.getRGBARed   rgba
+  r <- realToFrac <$> GDK.getRGBARed   rgba
-  g <- GDK.getRGBAGreen rgba
+  g <- realToFrac <$> GDK.getRGBAGreen rgba
-  b <- GDK.getRGBABlue  rgba
+  b <- realToFrac <$> GDK.getRGBABlue  rgba
-  a <- GDK.getRGBAAlpha rgba
+  a <- realToFrac <$> GDK.getRGBAAlpha rgba
   f r g b a
 
 showRGBA :: MonadIO m => GDK.RGBA -> m String