update "toggle guides" menu text on toggle

app/Main.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE NegativeLiterals    #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE RecursiveDo         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 
@@ -91,9 +92,7 @@ import MetaBrush.UI.FileBar
 import MetaBrush.UI.InfoBar
   ( InfoBar(..), createInfoBar, updateInfoBar )
 import MetaBrush.UI.Menu
-  ( createMenuBar
+  ( createMenuBar )
---, MenuItem(..), Menu(..), FileMenu(..), EditMenu(..), ViewMenu(..)
-  )
 import MetaBrush.UI.Panels
   ( createPanelBar )
 import MetaBrush.UI.ToolBar
@@ -348,30 +347,30 @@ main = do
 
   infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours
 
-  ---------------------------------------------------------
+  rec
-  -- File bar
 
-  fileBar@( FileBar { fileBarBox } ) <-
+    ---------------------------------------------------------
-    createFileBar
+    -- File bar
-      colours
+
-      variables
+      fileBar@( FileBar { fileBarBox } ) <-
-      window titleBar title viewport infoBar
+        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
 
-  let
-    uiElements :: UIElements
-    uiElements = UIElements {..}
-
-  ------------
-  -- Menu bar
-
-  _menu <- createMenuBar uiElements variables colours
-
-  --GTK.widgetSetSensitive ( menuItem $ close $ menuItemSubmenu $ file menu ) False
-
   ---------------------------------------------------------
   -- Panels
 

src/app/MetaBrush/Action.hs

@@ -74,6 +74,10 @@ import qualified Control.Concurrent.STM as STM
 import qualified Control.Concurrent.STM.TVar as STM
   ( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
 
+-- text
+import Data.Text
+  ( Text )
+
 -- MetaBrush
 import Math.Bezier.Stroke
   ( StrokePoint(..) )
@@ -115,6 +119,8 @@ import MetaBrush.UI.InfoBar
   ( updateInfoBar )
 import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( TabLocation(..), newFileTab, removeFileTab )
+import MetaBrush.UI.Menu
+  ( MenuItem(..), Menu(..), ViewMenu(..) )
 import MetaBrush.UI.ToolBar
   ( Tool(..) )
 import MetaBrush.UI.Viewport
@@ -490,8 +496,17 @@ data ToggleGuides = ToggleGuides
   deriving stock Show
 
 instance HandleAction ToggleGuides where
-  handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { showGuidesTVar } ) _ = do
+  handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { showGuidesTVar } ) _ = do
-    STM.atomically $ STM.modifyTVar' showGuidesTVar not
+    guidesWereShown <- STM.atomically do
+      guidesWereShown <- STM.readTVar showGuidesTVar
+      STM.writeTVar showGuidesTVar ( not guidesWereShown )
+      pure guidesWereShown
+    let
+      newText :: Text
+      newText
+        | guidesWereShown = "Show guides"
+        | otherwise       = "Hide guides"
+    GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText
     GTK.widgetQueueDraw viewportDrawingArea
     for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
       GTK.widgetQueueDraw drawingArea

src/app/MetaBrush/Action.hs-boot

@@ -0,0 +1,112 @@
+module MetaBrush.Action where
+
+-- base
+import Data.Word
+  ( Word32 )
+
+-- gi-gtk
+import qualified GI.Gtk as GTK
+
+-- MetaBrush
+import Math.Vector2D
+  ( Point2D, Vector2D )
+import {-# SOURCE #-} MetaBrush.Context
+  ( UIElements, Variables )
+import {-# SOURCE #-} MetaBrush.UI.FileBar
+  ( TabLocation(..) )
+import MetaBrush.UI.Viewport
+  ( Ruler(..) )
+import MetaBrush.Unique
+  ( Unique )
+
+--------------------------------------------------------------------------------
+
+class HandleAction action where
+  handleAction :: UIElements -> Variables -> action -> IO ()
+
+instance HandleAction ()
+
+data NewFile = NewFile TabLocation
+instance HandleAction NewFile
+
+data OpenFile = OpenFile TabLocation
+instance HandleAction OpenFile
+
+data OpenFolder = OpenFolder TabLocation
+instance HandleAction OpenFolder
+
+data Save = Save
+instance HandleAction Save
+
+data SaveAs = SaveAs
+instance HandleAction SaveAs
+
+data Close
+  = CloseActive
+  | CloseThis
+    { docToClose :: Unique }
+instance HandleAction Close
+
+data SwitchTo = SwitchTo Unique
+instance HandleAction SwitchTo
+
+data Quit = Quit
+instance HandleAction Quit
+quitEverything :: GTK.Window -> IO ()
+
+data Undo = Undo
+instance HandleAction Undo
+
+data Redo = Redo
+instance HandleAction Redo
+
+data DiscardChanges = DiscardChanges
+instance HandleAction DiscardChanges
+
+data Cut = Cut
+instance HandleAction Cut
+
+data Copy = Copy
+instance HandleAction Copy
+
+data Paste = Paste
+instance HandleAction Paste
+
+data Duplicate = Duplicate
+instance HandleAction Duplicate
+
+data Delete = Delete
+instance HandleAction Delete
+
+data ToggleGuides = ToggleGuides
+instance HandleAction ToggleGuides
+
+data Confirm = Confirm
+instance HandleAction Confirm
+
+data About = About
+instance HandleAction About
+
+data MouseMove = MouseMove ( Point2D Double )
+instance HandleAction MouseMove
+
+data ActionOrigin
+  = ViewportOrigin
+  | RulerOrigin Ruler
+data MouseClickType
+  = SingleClick
+  | DoubleClick
+data MouseClick = MouseClick ActionOrigin MouseClickType Word32 ( Point2D Double )
+instance HandleAction MouseClick
+
+data MouseRelease = MouseRelease Word32 ( Point2D Double )
+instance HandleAction MouseRelease
+
+data Scroll = Scroll ( Point2D Double ) ( Vector2D Double )
+instance HandleAction Scroll
+
+data KeyboardPress = KeyboardPress Word32
+instance HandleAction KeyboardPress
+
+data KeyboardRelease = KeyboardRelease Word32
+instance HandleAction KeyboardRelease

src/app/MetaBrush/Context.hs

@@ -1,12 +1,12 @@
 {-# LANGUAGE BlockArguments     #-}
 {-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE LambdaCase         #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE NamedFieldPuns     #-}
-{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.Context
   ( UIElements(..), Variables(..)
@@ -74,6 +74,8 @@ import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( FileBar, removeFileTab )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar, updateInfoBar )
+import {-# SOURCE #-} MetaBrush.UI.Menu
+  ( Menu, ResourceType(Object) )
 import MetaBrush.UI.ToolBar
   ( Tool, Mode )
 import MetaBrush.UI.Viewport
@@ -93,6 +95,7 @@ data UIElements
   , fileBar  :: !FileBar
   , viewport :: !Viewport
   , infoBar  :: !InfoBar
+  , menu     :: Menu Object -- needs to be lazy for "recursive do"
   , colours  :: !Colours
   }
 

src/app/MetaBrush/UI/FileBar.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments     #-}
+{-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns     #-}
 {-# LANGUAGE OverloadedStrings  #-}
@@ -50,6 +51,8 @@ import MetaBrush.Document
   ( Document(..), emptyDocument )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar, updateInfoBar )
+import {-# SOURCE #-} MetaBrush.UI.Menu
+  ( Menu, ResourceType(Object) )
 import MetaBrush.UI.Viewport
   ( Viewport(..) )
 import MetaBrush.Unique
@@ -184,12 +187,12 @@ newFileTab
 -- Updates the active document when buttons are clicked.
 createFileBar
   :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
   -> IO FileBar
 createFileBar
   colours
   vars@( Variables { openDocumentsTVar } )
-  window titleBar title viewport infoBar
+  window titleBar title viewport infoBar menu
   = do
 
     -- Create file bar: box containing scrollable tabs, and a "+" button after it.

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE DataKinds #-}
+
 module MetaBrush.UI.FileBar
   ( FileBar(..)
   , createFileBar, newFileTab, removeFileTab
@@ -17,6 +19,8 @@ import MetaBrush.Document
   ( Document )
 import {-# SOURCE #-} MetaBrush.UI.InfoBar
   ( InfoBar )
+import {-# SOURCE #-} MetaBrush.UI.Menu
+  ( Menu, ResourceType(Object) )
 import MetaBrush.UI.Viewport
   ( Viewport )
 import MetaBrush.Unique
@@ -39,7 +43,7 @@ instance Show TabLocation
 
 createFileBar
   :: Colours -> Variables
-  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar
+  -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object
   -> IO FileBar
 
 newFileTab

src/app/MetaBrush/UI/Menu.hs

@@ -60,7 +60,7 @@ import Control.Monad.IO.Class
   ( MonadIO(liftIO) )
 
 -- MetaBrush
-import MetaBrush.Action
+import {-# SOURCE #-} MetaBrush.Action
 import MetaBrush.Context
   ( UIElements(..), Variables(..)
   , LR(..), Modifier(..), modifierType
@@ -69,7 +69,7 @@ import MetaBrush.Asset.Colours
   ( Colours )
 import MetaBrush.Asset.WindowIcons
   ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
-import MetaBrush.UI.FileBar
+import {-# SOURCE #-} MetaBrush.UI.FileBar
   ( TabLocation(..) )
 import MetaBrush.Util
   ( widgetAddClass, widgetAddClasses )
@@ -159,7 +159,7 @@ data ViewMenu ( rt :: ResourceType )
   , viewSep2       :: !( Separator rt )
   , transform      :: !( MenuItem () NoSubresource rt )
   , viewSep3       :: !( Separator rt )
-  , guides         :: !( MenuItem ToggleGuides NoSubresource rt )
+  , toggleGuides   :: !( MenuItem ToggleGuides NoSubresource rt )
   }
   deriving stock Generic
 
@@ -219,7 +219,7 @@ viewMenuDescription
   , viewSep2       = SeparatorDescription                  [ "submenuSeparator" ]
   , transform      = MenuItemDescription  "Transform"      [ "submenuItem" ] () Nothing NoSubresource
   , viewSep3       = SeparatorDescription                  [ "submenuSeparator" ]
-  , guides         = MenuItemDescription  "Guides"         [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource
+  , toggleGuides   = MenuItemDescription  "Hide guides"    [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource
   }
 
 helpMenuDescription :: HelpMenu Description
@@ -305,7 +305,7 @@ newMenuBar uiElts vars accelGroup = do
 
 -- | Add the menu bar to the given box (title bar box).
 createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
-createMenuBar uiElts@( UIElements { titleBar, window } ) vars colours = do
+createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
   accelGroup <- GTK.accelGroupNew
   GTK.windowAddAccelGroup window accelGroup
   ( menuBar, menu ) <- newMenuBar uiElts vars accelGroup

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

@@ -0,0 +1,53 @@
+{-# 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/Viewport.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
-{-# LANGUAGE TypeApplications   #-}
 
 module MetaBrush.UI.Viewport
   ( Viewport(..), createViewport