hook up menu to actions, + some refactors

MetaBrush.cabal

@@ -150,8 +150,6 @@ executable MetaBrush
           ^>= 0.0.1
       , haskell-gi-base
           ^>= 0.24
-      , haskus-utils-variant
-          ^>= 3.0
       , lens
           ^>= 4.19.2
       , scientific

app/Main.hs

@@ -44,15 +44,9 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- haskus-utils-variant
-import Haskus.Utils.Variant
-  ( V )
-
 -- stm
 import qualified Control.Concurrent.STM as STM
   ( atomically )
-import qualified Control.Concurrent.STM.TQueue as STM
-  ( newTQueueIO )
 import qualified Control.Concurrent.STM.TVar as STM
   ( newTVarIO, readTVar )
 
@@ -65,8 +59,6 @@ import Math.Bezier.Stroke
   ( StrokePoint(..) )
 import Math.Vector2D
   ( Point2D(..) )
-import MetaBrush.Action
-  ( Actions, handleActions )
 import MetaBrush.Asset.Brushes
   ( ellipse, rect )
 import MetaBrush.Asset.Colours
@@ -201,8 +193,6 @@ main = do
     variables :: Variables
     variables = Variables { .. }
 
-  actionTQueue <- STM.newTQueueIO @( V Actions )
-
   ---------------------------------------------------------
   -- Initialise GTK
 
@@ -289,11 +279,6 @@ main = do
   void $ GTK.onWidgetDraw logoArea
     $ Cairo.renderWithContext ( drawLogo colours )
 
-  ------------
-  -- Menu bar
-
-  _ <- createMenuBar colours window titleBar
-
   ------------
   -- Title
 
@@ -345,12 +330,21 @@ main = do
   fileBar@( FileBar { fileBarBox } ) <-
     createFileBar
       variables
-      window title viewportDrawingArea infoBar
+      window titleBar title viewportDrawingArea infoBar
 
   GTK.boxPackStart mainView fileBarBox   False False 0
   GTK.boxPackStart mainView viewportGrid True  True  0
   GTK.boxPackStart mainView infoBarArea  False False 0
 
+  let
+    uiElements :: UIElements
+    uiElements = UIElements { .. }
+
+  ------------
+  -- Menu bar
+
+  _ <- createMenuBar uiElements variables colours
+
   ---------------------------------------------------------
   -- Panels
 
@@ -359,13 +353,7 @@ main = do
   ---------------------------------------------------------
   -- Actions
 
-  let
+  handleEvents uiElements variables
-    uiElements :: UIElements
-    uiElements = UIElements { .. }
-
-  handleEvents uiElements actionTQueue
-
-  void $ GDK.threadsAddIdle 200 ( handleActions actionTQueue uiElements variables )
 
   ---------------------------------------------------------
   -- GTK main loop

src/app/MetaBrush/Action.hs

@@ -2,18 +2,21 @@
 {-# LANGUAGE BlockArguments        #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns        #-}
-{-# LANGUAGE PatternSynonyms      #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
 module MetaBrush.Action
-  ( Actions, HandleAction(..)
+  ( HandleAction(..)
-  , handleActions, signalAction, quitEverything
+  , quitEverything
+  , NewFile(..), OpenFile(..), Save(..), SaveAs(..), Close(..), Quit(..)
+  , Undo(..), Redo(..), Cut(..), Copy(..), Paste(..), Duplicate(..), Delete(..)
+  , Confirm(..)
+  , About(..)
   , MouseMove(..), MouseClick(..), MouseRelease(..)
   , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
   )
@@ -23,7 +26,7 @@ module MetaBrush.Action
 import Control.Monad
   ( guard, unless, void )
 import Data.Foldable
-  ( for_, traverse_ )
+  ( for_ )
 import Data.Maybe
   ( catMaybes )
 import Data.Word
@@ -38,8 +41,6 @@ import Data.Act
   )
 
 -- containers
-import qualified Data.Map as Map
-  ( lookup )
 import Data.Sequence
   ( Seq(..) )
 import qualified Data.Sequence as Seq
@@ -53,19 +54,9 @@ import qualified GI.Gdk as GDK
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- haskus-utils-variant
-import Haskus.Utils.Variant
-  ( V, pattern V, ReduceVariant, reduceVariant
-  , type (:<)
-  )
-
 -- stm
-import Control.Concurrent.STM
-  ( STM )
 import qualified Control.Concurrent.STM as STM
   ( atomically )
-import qualified Control.Concurrent.STM.TQueue as STM
-  ( TQueue, flushTQueue, writeTQueue )
 import qualified Control.Concurrent.STM.TVar as STM
   ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
 
@@ -106,35 +97,205 @@ import MetaBrush.UI.ToolBar
 
 --------------------------------------------------------------------------------
 
-type Actions = [ MouseMove, MouseClick, MouseRelease, Scroll, KeyboardPress, KeyboardRelease ]
-
 class HandleAction action where
   handleAction :: UIElements -> Variables -> action -> IO ()
 
-instance ReduceVariant HandleAction actions => HandleAction ( V actions ) where
+--------------------------------------------------------------------------------
-  handleAction elts vars = reduceVariant @HandleAction ( handleAction elts vars )
+-- General actions
 
-handleActions :: ( Show action, HandleAction action ) => STM.TQueue action -> UIElements -> Variables -> IO Bool
+instance HandleAction () where
-handleActions actionTQueue elts vars = do
+  handleAction _ _ _ = pure ()
-  --actions <- STM.atomically do
-  --  actions <- STM.flushTQueue actionTQueue
-  --  if null actions
-  --  then STM.retry
-  --  else pure actions
-  actions <- STM.atomically $ STM.flushTQueue actionTQueue
-  traverse_ ( handleAction elts vars ) actions
-  pure True
 
-signalAction :: action :< actions => STM.TQueue ( V actions ) -> action  -> STM ()
+--------------
-signalAction tqueue = STM.writeTQueue tqueue . V
+-- New file --
+--------------
+
+data NewFile = NewFile TabLocation
+  deriving stock Show
+
+instance HandleAction NewFile where
+  handleAction uiElts vars ( NewFile tabLoc ) =
+    newFileTab vars uiElts Nothing tabLoc
+
+---------------
+-- Open file --
+---------------
+
+data OpenFile = OpenFile TabLocation
+  deriving stock Show
+
+instance HandleAction OpenFile where
+  handleAction _ _ _ = pure ()
+
+---------------
+-- Save file --
+---------------
+
+data Save = Save
+  deriving stock Show
+
+-- TODO
+instance HandleAction Save where
+  handleAction _ _ _ = pure ()
+
+-------------
+-- Save as --
+-------------
+
+data SaveAs = SaveAs
+  deriving stock Show
+
+-- TODO
+instance HandleAction SaveAs where
+  handleAction _ _ _ = pure ()
+
+-----------
+-- Close --
+-----------
+
+data Close = Close
+  deriving stock Show
+
+-- TODO
+instance HandleAction Close where
+  handleAction _ _ _ = pure ()
 
 --------------
 -- Quitting --
 --------------
 
+data Quit = Quit
+  deriving stock Show
+
+instance HandleAction Quit where
+  handleAction ( UIElements { window } ) _ _ = quitEverything window
+
 quitEverything :: GTK.Window -> IO ()
 quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
 
+----------
+-- Undo --
+----------
+
+data Undo = Undo
+  deriving stock Show
+
+-- TODO
+instance HandleAction Undo where
+  handleAction _ _ _ = pure ()
+
+----------
+-- Redo --
+----------
+
+data Redo = Redo
+  deriving stock Show
+
+-- TODO
+instance HandleAction Redo where
+  handleAction _ _ _ = pure ()
+
+---------
+-- Cut --
+---------
+
+data Cut = Cut
+  deriving stock Show
+
+-- TODO
+instance HandleAction Cut where
+  handleAction _ _ _ = pure ()
+
+----------
+-- Copy --
+----------
+
+data Copy = Copy
+  deriving stock Show
+
+-- TODO
+instance HandleAction Copy where
+  handleAction _ _ _ = pure ()
+
+-----------
+-- Paste --
+-----------
+
+data Paste = Paste
+  deriving stock Show
+
+-- TODO
+instance HandleAction Paste where
+  handleAction _ _ _ = pure ()
+
+---------------
+-- Duplicate --
+---------------
+
+data Duplicate = Duplicate
+  deriving stock Show
+
+-- TODO
+instance HandleAction Duplicate where
+  handleAction _ _ _ = pure ()
+
+------------
+-- Delete --
+------------
+
+data Delete = Delete
+  deriving stock Show
+
+instance HandleAction Delete where
+  handleAction
+    ( UIElements { viewportDrawingArea } )
+    vars@( Variables { toolTVar, modeTVar } )
+    _
+    = do
+        tool <- STM.readTVarIO toolTVar
+        mode <- STM.readTVarIO modeTVar
+        case tool of
+          -- Delete selected points on pressing 'Delete'.
+          Selection -> do
+            STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
+            GTK.widgetQueueDraw viewportDrawingArea
+          _ -> pure ()
+
+------------
+-- Confirm --
+------------
+
+data Confirm = Confirm
+  deriving stock Show
+
+instance HandleAction Confirm where
+  handleAction
+    ( UIElements { viewportDrawingArea } )
+    ( Variables { .. } )
+    _
+    = do
+        tool <- STM.readTVarIO toolTVar
+        case tool of
+          -- End ongoing drawing on pressing enter key.
+          Pen -> do
+            STM.atomically $ STM.writeTVar partialPathTVar Nothing
+            GTK.widgetQueueDraw viewportDrawingArea
+          _ -> pure ()
+
+----------------
+-- About page --
+----------------
+
+data About = About
+  deriving stock Show
+
+-- TODO
+instance HandleAction About where
+  handleAction _ _ _ = pure ()
+
+--------------------------------------------------------------------------------
+-- Input actions
+
 --------------------
 -- Mouse movement --
 --------------------
@@ -452,9 +613,9 @@ data KeyboardPress = KeyboardPress Word32
   deriving stock Show
 
 instance HandleAction KeyboardPress where
-  handleAction ( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
+  handleAction uiElts@( UIElements { .. } ) vars@( Variables { .. } ) ( KeyboardPress keyCode ) = do
 
-    modifiers <- STM.atomically do
+    _modifiers <- STM.atomically do
       !modifiers <- STM.readTVar modifiersTVar
       for_ ( modifierKey keyCode ) \ modifier ->
         ( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
@@ -462,26 +623,9 @@ instance HandleAction KeyboardPress where
 
     case keyCode of
 
-      GDK.KEY_Escape -> quitEverything window
+      GDK.KEY_Escape -> handleAction uiElts vars Quit
 
-      GDK.KEY_Return -> do
+      GDK.KEY_Return -> handleAction uiElts vars Confirm
-        tool <- STM.readTVarIO toolTVar
-        case tool of
-          -- End ongoing drawing on pressing enter key.
-          Pen -> do
-            STM.atomically $ STM.writeTVar partialPathTVar Nothing
-            GTK.widgetQueueDraw viewportDrawingArea
-          _ -> pure ()
-
-      GDK.KEY_Delete -> do
-        tool <- STM.readTVarIO toolTVar
-        mode <- STM.readTVarIO modeTVar
-        case tool of
-          -- Delete selected points on pressing 'Delete'.
-          Selection -> do
-            STM.atomically $ modifyingCurrentDocument vars ( pure . Just . deleteSelected mode )
-            GTK.widgetQueueDraw viewportDrawingArea
-          _ -> pure ()
 
       ctrl
         | ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
@@ -501,24 +645,6 @@ instance HandleAction KeyboardPress where
                   GTK.widgetQueueDraw viewportDrawingArea
             _ -> pure ()
 
-      GDK.KEY_F1 -> do
-        mbActiveDoc <- STM.readTVarIO activeDocumentTVar
-        for_ mbActiveDoc \ i -> do
-          docs <- STM.readTVarIO openDocumentsTVar
-          for_ ( Map.lookup i docs ) \ doc -> do
-            writeFile "log.txt" ( show doc <> "\n\n" )
-
-      -- Create a new document with Ctrl+N
-      n
-        | ( n == GDK.KEY_n || n == GDK.KEY_N )
-        , any ( \ case { Control _ -> True; _ -> False } ) modifiers
-        ->
-          newFileTab
-            vars
-            window title fileBar viewportDrawingArea infoBar
-            Nothing
-            AfterCurrentTab
-
       _ -> pure ()
 
 ----------------------

src/app/MetaBrush/Context.hs

@@ -60,6 +60,7 @@ data UIElements
   = UIElements
   { window              :: !GTK.Window
   , title               :: !GTK.Label
+  , titleBar            :: !GTK.Box
   , fileBar             :: !FileBar
   , viewportDrawingArea :: !GTK.DrawingArea
   , infoBar             :: !InfoBar

src/app/MetaBrush/Document/Selection.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
-{-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 

src/app/MetaBrush/Event.hs

@@ -6,48 +6,38 @@ module MetaBrush.Event
   ( handleEvents )
   where
 
--- haskus-utils-variant
-import Haskus.Utils.Variant
-  ( V, type (:<), type (:<<) )
-
 -- gi-gdk
 import qualified GI.Gdk as GDK
 
 -- gi-gtk
 import qualified GI.Gtk as GTK
 
--- stm
-import qualified Control.Concurrent.STM      as STM
-  ( atomically )
-import qualified Control.Concurrent.STM.TQueue as STM
-  ( TQueue )
-
 -- MetaBrush
 import Math.Vector2D
   ( Point2D(..), Vector2D(..) )
 import MetaBrush.Action
-  ( Actions
+  ( HandleAction(..)
   , MouseMove(..), MouseClick(..), MouseRelease(..)
   , Scroll(..), KeyboardPress(..), KeyboardRelease(..)
-  , signalAction, quitEverything
+  , quitEverything
   )
 import MetaBrush.Context
-  ( UIElements(..) )
+  ( UIElements(..), Variables(..) )
 
 --------------------------------------------------------------------------------
 
-handleEvents :: Actions :<< action => UIElements -> STM.TQueue ( V action ) -> IO ()
+handleEvents :: UIElements -> Variables -> IO ()
-handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do
+handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do
 
   -- Mouse events
-  _ <- GTK.onWidgetMotionNotifyEvent  viewportDrawingArea ( handleMotionEvent actionTQueue )
+  _ <- GTK.onWidgetMotionNotifyEvent  viewportDrawingArea ( handleMotionEvent        elts vars )
-  _ <- GTK.onWidgetScrollEvent        viewportDrawingArea ( handleScrollEvent actionTQueue )
+  _ <- GTK.onWidgetScrollEvent        viewportDrawingArea ( handleScrollEvent        elts vars )
-  _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea ( handleMouseButtonEvent actionTQueue )
+  _ <- GTK.onWidgetButtonPressEvent   viewportDrawingArea ( handleMouseButtonEvent   elts vars )
-  _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease actionTQueue )
+  _ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
 
   -- Keyboard events
-  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   actionTQueue )
+  _ <- GTK.onWidgetKeyPressEvent   window ( handleKeyboardPressEvent   elts vars )
-  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue )
+  _ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
 
   -- Window quit
   _ <- GTK.onWidgetDestroy window ( quitEverything window )
@@ -57,49 +47,49 @@ handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do
 --------------------------------------------------------------------------------
 -- Mouse events.
 
-handleMotionEvent :: MouseMove :< action => STM.TQueue ( V action ) -> GDK.EventMotion -> IO Bool
+handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool
-handleMotionEvent actionTQueue eventMotion = do
+handleMotionEvent elts vars eventMotion = do
   x <- GDK.getEventMotionX eventMotion
   y <- GDK.getEventMotionY eventMotion
-  STM.atomically $ signalAction actionTQueue ( MouseMove ( Point2D x y ) )
+  handleAction elts vars ( MouseMove ( Point2D x y ) )
   pure True
 
-handleScrollEvent :: Scroll :< action => STM.TQueue ( V action ) -> GDK.EventScroll -> IO Bool
+handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool
-handleScrollEvent actionTQueue scrollEvent = do
+handleScrollEvent elts vars scrollEvent = do
   dx <- GDK.getEventScrollDeltaX scrollEvent
   dy <- GDK.getEventScrollDeltaY scrollEvent
   x  <- GDK.getEventScrollX scrollEvent
   y  <- GDK.getEventScrollY scrollEvent
-  STM.atomically $ signalAction actionTQueue ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
+  handleAction elts vars ( Scroll ( Point2D x y ) ( Vector2D dx dy ) )
   pure False
 
-handleMouseButtonEvent :: MouseClick :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
+handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool
-handleMouseButtonEvent actionTQueue mouseClickEvent = do
+handleMouseButtonEvent elts vars mouseClickEvent = do
   button <- GDK.getEventButtonButton mouseClickEvent
   x <- GDK.getEventButtonX mouseClickEvent
   y <- GDK.getEventButtonY mouseClickEvent
-  STM.atomically $ signalAction actionTQueue ( MouseClick button ( Point2D x y ) )
+  handleAction elts vars ( MouseClick button ( Point2D x y ) )
   pure False
 
-handleMouseButtonRelease :: MouseRelease :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
+handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool
-handleMouseButtonRelease actionTQueue mouseReleaseEvent = do
+handleMouseButtonRelease elts vars mouseReleaseEvent = do
   button <- GDK.getEventButtonButton mouseReleaseEvent
   x <- GDK.getEventButtonX mouseReleaseEvent
   y <- GDK.getEventButtonY mouseReleaseEvent
-  STM.atomically $ signalAction actionTQueue ( MouseRelease button ( Point2D x y ) )
+  handleAction elts vars ( MouseRelease button ( Point2D x y ) )
   pure False
 
 --------------------------------------------------------------------------------
 -- Keyboard events.
 
-handleKeyboardPressEvent :: KeyboardPress :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
+handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
-handleKeyboardPressEvent actionTQueue evt = do
+handleKeyboardPressEvent elts vars evt = do
   keyCode <- GDK.getEventKeyKeyval evt
-  STM.atomically $ signalAction actionTQueue ( KeyboardPress keyCode )
+  handleAction elts vars ( KeyboardPress keyCode )
   pure True
 
-handleKeyboardReleaseEvent :: KeyboardRelease :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
+handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
-handleKeyboardReleaseEvent actionTQueue evt = do
+handleKeyboardReleaseEvent elts vars evt = do
   keyCode <- GDK.getEventKeyKeyval evt
-  STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode )
+  handleAction elts vars ( KeyboardRelease keyCode )
   pure True

src/app/MetaBrush/UI/FileBar.hs

@@ -38,7 +38,7 @@ import Data.Text
 
 -- MetaBrush
 import MetaBrush.Context
-  ( Variables(..) )
+  ( UIElements(..), Variables(..) )
 import MetaBrush.Document
   ( Document(..), emptyDocument )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
@@ -66,13 +66,13 @@ data TabLocation
 
 newFileTab
   :: Variables
-  -> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea  -> InfoBar
+  -> UIElements
   -> Maybe Document
   -> TabLocation
   -> IO ()
 newFileTab
   vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } )
-  window title ( FileBar { fileTabsBox, fileBarPhantomRadioButton } ) viewportArea infoBar
+  ( UIElements { fileBar = FileBar {..}, .. } )
   mbDoc
   newTabLoc
   = do
@@ -140,7 +140,7 @@ newFileTab
     STM.atomically do
       STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
       STM.writeTVar  activeDocumentTVar ( Just newUnique )
-    GTK.widgetQueueDraw viewportArea
+    GTK.widgetQueueDraw viewportDrawingArea
 
     void $ GTK.onButtonClicked pgButton do
       isActive <- GTK.toggleButtonGetActive pgButton
@@ -164,13 +164,16 @@ newFileTab
                 = displayName <> " – MetaBrush"
             GTK.labelSetText   title  titleText
             GTK.setWindowTitle window titleText
-            updateInfoBar viewportArea infoBar vars
+            updateInfoBar viewportDrawingArea infoBar vars
-            GTK.widgetQueueDraw viewportArea
+            GTK.widgetQueueDraw viewportDrawingArea
       else do
         GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
         GTK.labelSetText   title  "MetaBrush"
         GTK.setWindowTitle window "MetaBrush"
 
+    --void $ GTK.onButtonClicked closeFileButton
+    --  ( STM.atomically $ signalAction actionTQueue Close )
+
     --void $ GTK.onButtonClicked closeFileButton ... ... ...
 
     GTK.toggleButtonSetActive pgButton True
@@ -180,11 +183,11 @@ newFileTab
 -- Updates the active document when buttons are clicked.
 createFileBar
   :: Variables
-  -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
   -> IO FileBar
 createFileBar
   vars@( Variables { openDocumentsTVar } )
-  window title viewportArea infoBar
+  window titleBar title viewportDrawingArea infoBar
   = do
 
     -- Create file bar: box containing scrollable tabs, and a "+" button after it.
@@ -211,19 +214,21 @@ createFileBar
     let
       fileBar :: FileBar
       fileBar = FileBar { .. }
+      uiElements :: UIElements
+      uiElements = UIElements { .. }
 
     documents <- STM.readTVarIO openDocumentsTVar
     for_ documents \ doc ->
       newFileTab
         vars
-        window title fileBar viewportArea infoBar
+        uiElements
         ( Just doc )
         LastTab
 
     void $ GTK.onButtonClicked newFileButton do
       newFileTab
         vars
-        window title fileBar viewportArea infoBar
+        uiElements
         Nothing
         LastTab
 

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

@@ -9,7 +9,7 @@ import qualified GI.Gtk as GTK
 
 -- MetaBrush
 import {-# SOURCE #-} MetaBrush.Context
-  ( Variables )
+  ( Variables, UIElements )
 import MetaBrush.Document
   ( Document )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
@@ -28,14 +28,11 @@ data TabLocation
   = AfterCurrentTab
   | LastTab
 
+instance Show TabLocation
+
 createFileBar
   :: Variables
-  -> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
   -> IO FileBar
 
-newFileTab
+newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO ()
-  :: Variables
-  -> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
-  -> Maybe Document
-  -> TabLocation
-  -> IO ()

src/app/MetaBrush/UI/Menu.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments         #-}
+{-# LANGUAGE ConstraintKinds        #-}
 {-# LANGUAGE DataKinds              #-}
 {-# LANGUAGE DeriveGeneric          #-}
 {-# LANGUAGE DerivingStrategies     #-}
@@ -10,6 +11,7 @@
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE RecordWildCards        #-}
+{-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 
@@ -59,17 +61,18 @@ import Control.Monad.IO.Class
 
 -- MetaBrush
 import MetaBrush.Action
-  ( quitEverything )
 import MetaBrush.Context
-  ( LR(..), Modifier(..), modifierType )
+  ( UIElements(..), Variables(..)
+  , LR(..), Modifier(..), modifierType
+  )
 import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Asset.WindowIcons
   ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
+import MetaBrush.UI.FileBar
+  ( TabLocation(..) )
 import MetaBrush.Util
-  ( widgetAddClass, widgetAddClasses
+  ( widgetAddClass, widgetAddClasses )
-  , (>>?=)
-  )
 
 --------------------------------------------------------------------------------
 -- Types for describing menu items.
@@ -78,16 +81,16 @@ data ResourceType
   = Description
   | Object
 
-data family   MenuItem ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
+data family   MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
-data instance MenuItem submenu Description 
+data instance MenuItem action submenu Description 
   = MenuItemDescription
     { menuItemLabel      :: !Text
     , menuItemClasses    :: ![ Text ]
-    , menuItemAction     :: !( Maybe Text )
+    , menuItemAction     :: !action
     , menuItemAccel      :: !( Maybe ( Word32, [ Modifier ] ) )
     , submenuDescription :: !( submenu Description )
     }
-data instance MenuItem submenu Object 
+data instance MenuItem action submenu Object 
   = MenuItem
   { menuItem        :: !GTK.MenuItem
   , menuItemSubmenu :: !( submenu Object )
@@ -110,41 +113,55 @@ data NoSubresource ( k :: ResourceType ) = NoSubresource
 
 data Menu ( rt :: ResourceType )
   = Menu
-  { file :: !( MenuItem FileMenu rt )
+  { file :: !( MenuItem () FileMenu rt )
-  , edit :: !( MenuItem EditMenu rt )
+  , edit :: !( MenuItem () EditMenu rt )
-  , view :: !( MenuItem ViewMenu rt )
+  , view :: !( MenuItem () ViewMenu rt )
-  , help :: !( MenuItem HelpMenu rt )
+  , help :: !( MenuItem () HelpMenu rt )
   }
   deriving stock Generic
 
 data FileMenu ( rt :: ResourceType )
   = FileMenu
-  { new, open, save, saveAs, close, quit :: !( MenuItem NoSubresource rt ) }
+  { new    :: !( MenuItem NewFile  NoSubresource rt )
+  , open   :: !( MenuItem OpenFile NoSubresource rt )
+  , save   :: !( MenuItem Save     NoSubresource rt )
+  , saveAs :: !( MenuItem SaveAs   NoSubresource rt )
+  , close  :: !( MenuItem Close    NoSubresource rt )
+  , quit   :: !( MenuItem Quit     NoSubresource rt )
+  }
   deriving stock Generic
 
 data EditMenu ( rt :: ResourceType )
   = EditMenu
-  { undo, redo, history :: !( MenuItem  NoSubresource rt )
+  { undo        :: !( MenuItem Undo      NoSubresource rt )
+  , redo        :: !( MenuItem Redo      NoSubresource rt )
   , editSep1    :: !( Separator rt )
-  , cut, copy, paste, duplicate, delete :: !( MenuItem  NoSubresource rt )
+  , cut         :: !( MenuItem Cut       NoSubresource rt )
+  , copy        :: !( MenuItem Copy      NoSubresource rt )
+  , paste       :: !( MenuItem Paste     NoSubresource rt )
+  , duplicate   :: !( MenuItem Duplicate NoSubresource rt )
+  , delete      :: !( MenuItem Delete    NoSubresource rt )
   , editSep2    :: !( Separator rt )
-  , preferences :: !( MenuItem  NoSubresource rt )
+  , preferences :: !( MenuItem ()        NoSubresource rt )
   }
   deriving stock Generic
 
 data ViewMenu ( rt :: ResourceType )
   = ViewMenu
-  { navigator :: !( MenuItem  NoSubresource rt )
+  { navigator      :: !( MenuItem () NoSubresource rt )
+  , history        :: !( MenuItem () NoSubresource rt )
   , viewSep1       :: !( Separator rt )
-  , strokes, brushes, metaparameters :: !( MenuItem  NoSubresource rt )
+  , strokes        :: !( MenuItem () NoSubresource rt )
+  , brushes        :: !( MenuItem () NoSubresource rt )
+  , metaparameters :: !( MenuItem () NoSubresource rt )
   , viewSep2       :: !( Separator rt )
-  , transform :: !( MenuItem  NoSubresource rt )
+  , transform      :: !( MenuItem () NoSubresource rt )
   }
   deriving stock Generic
 
 data HelpMenu ( rt :: ResourceType )
   = HelpMenu
-  { about :: !( MenuItem NoSubresource rt ) }
+  { about :: !( MenuItem About NoSubresource rt ) }
   deriving stock Generic
 
 -- Descriptions.
@@ -152,93 +169,103 @@ data HelpMenu ( rt :: ResourceType )
 menuDescription :: Menu Description
 menuDescription
   = Menu
-  { file = MenuItemDescription "File" [ "menuItem", "file" ] Nothing Nothing fileMenuDescription
+  { file = MenuItemDescription "File" [ "menuItem", "file" ] () Nothing fileMenuDescription
-  , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing Nothing editMenuDescription
+  , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] () Nothing editMenuDescription
-  , view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing Nothing viewMenuDescription
+  , view = MenuItemDescription "View" [ "menuItem", "view" ] () Nothing viewMenuDescription
-  , help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing Nothing helpMenuDescription
+  , help = MenuItemDescription "Help" [ "menuItem", "help" ] () Nothing helpMenuDescription
   }
 
 fileMenuDescription :: FileMenu Description
 fileMenuDescription
   = FileMenu
-  { new    = MenuItemDescription "New"     [ "submenuItem" ] Nothing ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
+  { new    = MenuItemDescription "New"     [ "submenuItem" ] ( NewFile  AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
-  , open   = MenuItemDescription "Open"    [ "submenuItem" ] Nothing ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
+  , open   = MenuItemDescription "Open"    [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
-  , save   = MenuItemDescription "Save"    [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
+  , save   = MenuItemDescription "Save"    [ "submenuItem" ] Save                         ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
-  , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
+  , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs                       ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
-  , close  = MenuItemDescription "Close"   [ "submenuItem" ] Nothing ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
+  , close  = MenuItemDescription "Close"   [ "submenuItem" ] Close                        ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
-  , quit   = MenuItemDescription "Quit"    [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
+  , quit   = MenuItemDescription "Quit"    [ "submenuItem" ] Quit                         ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
   }
 
 editMenuDescription :: EditMenu Description
 editMenuDescription
   = EditMenu
-  { undo        = MenuItemDescription  "Undo"        [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
+  { undo        = MenuItemDescription  "Undo"        [ "submenuItem" ] Undo      ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
-  , redo        = MenuItemDescription  "Redo"        [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
+  , redo        = MenuItemDescription  "Redo"        [ "submenuItem" ] Redo      ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
-  , history     = MenuItemDescription  "History"     [ "submenuItem" ] Nothing ( Just ( GDK.KEY_H, [ Control L ] ) ) NoSubresource
   , editSep1    = SeparatorDescription               [ "submenuSeparator" ]
-  , cut         = MenuItemDescription  "Cut"         [ "submenuItem" ] Nothing ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
+  , cut         = MenuItemDescription  "Cut"         [ "submenuItem" ] Cut       ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
-  , copy        = MenuItemDescription  "Copy"        [ "submenuItem" ] Nothing ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
+  , copy        = MenuItemDescription  "Copy"        [ "submenuItem" ] Copy      ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
-  , paste       = MenuItemDescription  "Paste"       [ "submenuItem" ] Nothing ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
+  , paste       = MenuItemDescription  "Paste"       [ "submenuItem" ] Paste     ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
-  , duplicate   = MenuItemDescription  "Duplicate"   [ "submenuItem" ] Nothing ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
+  , duplicate   = MenuItemDescription  "Duplicate"   [ "submenuItem" ] Duplicate ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
-  , delete      = MenuItemDescription  "Delete"      [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Delete, [] ) )       NoSubresource
+  , delete      = MenuItemDescription  "Delete"      [ "submenuItem" ] Delete    ( Just ( GDK.KEY_Delete, [] ) )       NoSubresource
   , editSep2    = SeparatorDescription               [ "submenuSeparator" ]
-  , preferences = MenuItemDescription  "Preferences" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource
+  , preferences = MenuItemDescription  "Preferences" [ "submenuItem" ] ()        ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource
   }
 
 viewMenuDescription :: ViewMenu Description
 viewMenuDescription
   = ViewMenu
-  { navigator      = MenuItemDescription  "Navigator"      [ "submenuItem" ] Nothing Nothing NoSubresource
+  { 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 Nothing NoSubresource
+  , strokes        = MenuItemDescription  "Strokes"        [ "submenuItem" ] () Nothing NoSubresource
-  , brushes        = MenuItemDescription  "Brushes"        [ "submenuItem" ] Nothing Nothing NoSubresource
+  , brushes        = MenuItemDescription  "Brushes"        [ "submenuItem" ] () Nothing NoSubresource
-  , metaparameters = MenuItemDescription  "Metaparameters" [ "submenuItem" ] Nothing Nothing NoSubresource
+  , metaparameters = MenuItemDescription  "Metaparameters" [ "submenuItem" ] () Nothing NoSubresource
   , viewSep2       = SeparatorDescription                  [ "submenuSeparator" ]
-  , transform      = MenuItemDescription  "Transform"      [ "submenuItem" ] Nothing Nothing NoSubresource
+  , transform      = MenuItemDescription  "Transform"      [ "submenuItem" ] () Nothing NoSubresource
   }
 
 helpMenuDescription :: HelpMenu Description
 helpMenuDescription
   = HelpMenu
-  { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource }
+  { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] About ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource }
 
 --------------------------------------------------------------------------------
 -- Creating a GTK menu bar from a menu description.
 
-newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem
+newMenuItem
-newMenuItem ( MenuItemDescription { .. } ) = do
+  :: ( MonadIO m, HandleAction action )
+  => UIElements
+  -> Variables
+  -> GTK.AccelGroup
+  -> MenuItem action submenu Description
+  -> m GTK.MenuItem
+newMenuItem uiElts vars accelGroup ( MenuItemDescription { .. } ) = do
   menuItem <- GTK.menuItemNewWithLabel menuItemLabel
   for_ menuItemAccel \ ( key, modifiers ) -> do
-    mbAccelLabel <- liftIO ( GTK.binGetChild menuItem >>?= ( GTK.castTo GTK.AccelLabel ) )
+    GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
-    for_ mbAccelLabel \ accelLabel -> do
+    GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel"
-      GTK.accelLabelSetAccel accelLabel key ( map modifierType modifiers )
-      widgetAddClass accelLabel "accelLabel"
   unless ( null menuItemClasses ) do
     widgetAddClasses menuItem menuItemClasses
-  for_ menuItemAction \ actionName -> do
+  void $ GTK.onMenuItemActivate menuItem
-    GTK.actionableSetActionName menuItem ( Just actionName )
+    ( handleAction uiElts vars menuItemAction )
   pure menuItem
 
 class CreateMenuItem desc res | desc -> res, res -> desc where
-  createMenuItem :: MonadIO m => ( GTK.MenuItem -> m () ) -> desc -> m res
+  createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res
-instance {-# OVERLAPPING #-} CreateMenuItem ( MenuItem NoSubresource Description ) ( MenuItem NoSubresource Object ) where
+instance {-# OVERLAPPING #-}
-  createMenuItem attachToParent menuItemDescription = do
+  HandleAction action
-    menuItem <- newMenuItem menuItemDescription 
+  =>  CreateMenuItem
+        ( MenuItem action NoSubresource Description )
+        ( MenuItem action NoSubresource Object )
+    where
+  createMenuItem uiElts vars accelGroup attachToParent menuItemDescription = do
+    menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription 
     attachToParent menuItem
     pure 
       MenuItem
       { menuItem        = menuItem
       , menuItemSubmenu = NoSubresource
       }
-instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
+instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
-      => CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object )
+      => CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object )
       where
-  createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
+  createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
-    menuItem <- newMenuItem menuItemDescription
+    menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription
     submenu <- GTK.menuNew
+    GTK.menuSetAccelGroup submenu ( Just accelGroup )
     submenuItems <-
       constraints @CreateMenuItem
-        ( createMenuItem ( GTK.menuShellAppend submenu ) )
+        ( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend submenu ) )
         submenuDescription
     GTK.menuItemSetSubmenu menuItem ( Just submenu )
     attachToParent menuItem
@@ -248,7 +275,7 @@ instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Objec
       , menuItemSubmenu = submenuItems
       }
 instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
-  createMenuItem attachToParent ( SeparatorDescription { .. } ) = do
+  createMenuItem _ _ _ attachToParent ( SeparatorDescription { .. } ) = do
     separator <- GTK.separatorMenuItemNew
     unless ( null separatorClasses ) do
       widgetAddClasses separator separatorClasses
@@ -256,12 +283,12 @@ instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
     attachToParent sep
     pure ( Separator { separatorItem = sep } )
 
-newMenuBar :: MonadIO m => m ( GTK.MenuBar, Menu Object )
+newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
-newMenuBar = do
+newMenuBar uiElts vars accelGroup = do
   menuBar <- GTK.menuBarNew
   menu <-
     constraints @CreateMenuItem
-      ( createMenuItem ( GTK.menuShellAppend menuBar ) )
+      ( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend menuBar ) )
       menuDescription
   pure ( menuBar, menu )
 
@@ -269,9 +296,11 @@ newMenuBar = do
 -- Creating the menu bar from its declarative specification.
 
 -- | Add the menu bar to the given box (title bar box).
-createMenuBar :: Colours -> GTK.Window -> GTK.Box -> IO ( Menu Object )
+createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
-createMenuBar colours window titleBar = do
+createMenuBar uiElts@( UIElements { titleBar, window } ) vars colours = do
-  ( menuBar, menu ) <- newMenuBar
+  accelGroup <- GTK.accelGroupNew
+  GTK.windowAddAccelGroup window accelGroup
+  ( menuBar, menu ) <- newMenuBar uiElts vars accelGroup
   widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
   GTK.boxPackStart titleBar menuBar False False 0
 

src/lib/Math/Bezier/Cubic/Fit.hs

@@ -101,7 +101,7 @@ fitSpline maxSubdiv nbSegments dist_tol t_tol maxIters = go 0
         qs :: [ Point2D Double ]
         (p, tp) = curve 0
         (r, tr) = curve 1
-        qs = map ( fst . curve ) [ dt * fromIntegral j | j <- [ 1 .. nbSegments - 1 ] ]
+        qs = [ fst $ curve ( dt * fromIntegral j ) | j <- [ 1 .. nbSegments - 1 ] ]
       in
         case fitPiece dist_tol t_tol maxIters p tp qs r tr of
           ( bez, Max ( Arg t_split sq_d ) )