From 919acf49286bd5127eab8aa903d890a7619087d9 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 2 Sep 2020 15:58:00 +0200 Subject: [PATCH] add accelerator labels to menu items --- assets/theme.css | 10 ++++++ src/app/MetaBrush/Action.hs | 7 ++-- src/app/MetaBrush/Context.hs | 7 +++- src/app/MetaBrush/UI/Menu.hs | 65 +++++++++++++++++++++--------------- 4 files changed, 56 insertions(+), 33 deletions(-) diff --git a/assets/theme.css b/assets/theme.css index 32c678f..1d91cad 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -239,6 +239,16 @@ tooltip { border-color: rgb(234,223,204); } +.accelLabel { + padding: 2px 8px 2px 0px; +} + +.accelLabel accelerator { + font-size: 10px; + color: rgb(112, 109, 96); + padding: 0px; +} + .windowIcon { min-width: 24px; } diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 7baa097..98000d0 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -63,7 +63,7 @@ import Haskus.Utils.Variant import Control.Concurrent.STM ( STM ) import qualified Control.Concurrent.STM as STM - ( atomically, retry ) + ( atomically ) import qualified Control.Concurrent.STM.TQueue as STM ( TQueue, flushTQueue, writeTQueue ) import qualified Control.Concurrent.STM.TVar as STM @@ -104,8 +104,6 @@ import MetaBrush.UI.FileBar import MetaBrush.UI.ToolBar ( Tool(..) ) -import Debug.Trace - -------------------------------------------------------------------------------- type Actions = [ MouseMove, MouseClick, MouseRelease, Scroll, KeyboardPress, KeyboardRelease ] @@ -118,13 +116,12 @@ instance ReduceVariant HandleAction actions => HandleAction ( V actions ) where handleActions :: ( Show action, HandleAction action ) => STM.TQueue action -> UIElements -> Variables -> IO Bool handleActions actionTQueue elts vars = do - actions <- STM.atomically $ STM.flushTQueue actionTQueue - --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 diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 26b0f86..1659785 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -4,7 +4,7 @@ module MetaBrush.Context ( UIElements(..), Variables(..) - , LR(..), Modifier(..), modifierKey + , LR(..), Modifier(..), modifierKey, modifierType , HoldAction(..), PartialPath(..) , currentDocument, withCurrentDocument, modifyingCurrentDocument ) @@ -98,6 +98,11 @@ modifierKey GDK.KEY_Alt_L = Just ( Alt L ) modifierKey GDK.KEY_Alt_R = Just ( Alt R ) modifierKey _ = Nothing +modifierType :: Modifier -> GDK.ModifierType +modifierType ( Control _ ) = GDK.ModifierTypeControlMask +modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask +modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask + -- | Keep track of a mouse hold action: -- -- - start a rectangular selection, diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 0b1a612..45beb70 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -30,6 +30,8 @@ import Data.Foldable ( for_ ) import Data.Kind ( Type ) +import Data.Word + ( Word32 ) import GHC.Generics ( Generic ) @@ -58,12 +60,16 @@ import Control.Monad.IO.Class -- MetaBrush import MetaBrush.Action ( quitEverything ) +import MetaBrush.Context + ( LR(..), Modifier(..), modifierType ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) import MetaBrush.Util - ( widgetAddClass, widgetAddClasses ) + ( widgetAddClass, widgetAddClasses + , (>>?=) + ) -------------------------------------------------------------------------------- -- Types for describing menu items. @@ -78,6 +84,7 @@ data instance MenuItem submenu Description { menuItemLabel :: !Text , menuItemClasses :: ![ Text ] , menuItemAction :: !( Maybe Text ) + , menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) ) , submenuDescription :: !( submenu Description ) } data instance MenuItem submenu Object @@ -145,55 +152,55 @@ data HelpMenu ( rt :: ResourceType ) 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 + { file = MenuItemDescription "File" [ "menuItem", "file" ] Nothing Nothing fileMenuDescription + , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing Nothing editMenuDescription + , view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing Nothing viewMenuDescription + , help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing Nothing helpMenuDescription } fileMenuDescription :: FileMenu Description fileMenuDescription = FileMenu - { new = MenuItemDescription "New" [ "submenuItem" ] Nothing NoSubresource - , open = MenuItemDescription "Open" [ "submenuItem" ] Nothing NoSubresource - , save = MenuItemDescription "Save" [ "submenuItem" ] Nothing NoSubresource - , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing NoSubresource - , close = MenuItemDescription "Close" [ "submenuItem" ] Nothing NoSubresource - , quit = MenuItemDescription "Quit" [ "submenuItem" ] Nothing NoSubresource + { new = MenuItemDescription "New" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource + , open = MenuItemDescription "Open" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource + , save = MenuItemDescription "Save" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource + , saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource + , close = MenuItemDescription "Close" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource + , quit = MenuItemDescription "Quit" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource } editMenuDescription :: EditMenu Description editMenuDescription = EditMenu - { undo = MenuItemDescription "Undo" [ "submenuItem" ] Nothing NoSubresource - , redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing NoSubresource - , history = MenuItemDescription "History" [ "submenuItem" ] Nothing NoSubresource + { undo = MenuItemDescription "Undo" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource + , redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing ( 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 NoSubresource - , copy = MenuItemDescription "Copy" [ "submenuItem" ] Nothing NoSubresource - , paste = MenuItemDescription "Paste" [ "submenuItem" ] Nothing NoSubresource - , duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Nothing NoSubresource - , delete = MenuItemDescription "Delete" [ "submenuItem" ] Nothing NoSubresource + , cut = MenuItemDescription "Cut" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource + , copy = MenuItemDescription "Copy" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource + , paste = MenuItemDescription "Paste" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource + , duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource + , delete = MenuItemDescription "Delete" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Delete, [] ) ) NoSubresource , editSep2 = SeparatorDescription [ "submenuSeparator" ] - , preferences = MenuItemDescription "Preferences" [ "submenuItem" ] Nothing NoSubresource + , preferences = MenuItemDescription "Preferences" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource } viewMenuDescription :: ViewMenu Description viewMenuDescription = ViewMenu - { navigator = MenuItemDescription "Navigator" [ "submenuItem" ] Nothing NoSubresource + { navigator = MenuItemDescription "Navigator" [ "submenuItem" ] Nothing Nothing NoSubresource , viewSep1 = SeparatorDescription [ "submenuSeparator" ] - , strokes = MenuItemDescription "Strokes" [ "submenuItem" ] Nothing NoSubresource - , brushes = MenuItemDescription "Brushes" [ "submenuItem" ] Nothing NoSubresource - , metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] Nothing NoSubresource + , strokes = MenuItemDescription "Strokes" [ "submenuItem" ] Nothing Nothing NoSubresource + , brushes = MenuItemDescription "Brushes" [ "submenuItem" ] Nothing Nothing NoSubresource + , metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] Nothing Nothing NoSubresource , viewSep2 = SeparatorDescription [ "submenuSeparator" ] - , transform = MenuItemDescription "Transform" [ "submenuItem" ] Nothing NoSubresource + , transform = MenuItemDescription "Transform" [ "submenuItem" ] Nothing Nothing NoSubresource } helpMenuDescription :: HelpMenu Description helpMenuDescription = HelpMenu - { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing NoSubresource } + { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource } -------------------------------------------------------------------------------- -- Creating a GTK menu bar from a menu description. @@ -201,7 +208,11 @@ helpMenuDescription newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem newMenuItem ( MenuItemDescription { .. } ) = do menuItem <- GTK.menuItemNewWithLabel menuItemLabel - -- Could set accelerator labels... + for_ menuItemAccel \ ( key, modifiers ) -> do + mbAccelLabel <- liftIO ( GTK.binGetChild menuItem >>?= ( GTK.castTo GTK.AccelLabel ) ) + for_ mbAccelLabel \ accelLabel -> do + GTK.accelLabelSetAccel accelLabel key ( map modifierType modifiers ) + widgetAddClass accelLabel "accelLabel" unless ( null menuItemClasses ) do widgetAddClasses menuItem menuItemClasses for_ menuItemAction \ actionName -> do