hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 14:53:37 +00:00
Code Issues Actions Projects Releases Wiki Activity

add accelerator labels to menu items

Browse source
This commit is contained in:
sheaf 2020-09-02 15:58:00 +02:00
parent 7033578e20
commit 919acf4928
4 changed files with 56 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
assets/theme.css
View file

@ -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;
}

7
src/app/MetaBrush/Action.hs
View file

@ -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

7
src/app/MetaBrush/Context.hs
View file

@ -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,

65
src/app/MetaBrush/UI/Menu.hs
View file

@ -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