mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-06 07:13:37 +00:00
351 lines
13 KiB
Haskell
351 lines
13 KiB
Haskell
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DeriveGeneric #-}
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PolyKinds #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module MetaBrush.UI.Menu
|
|
( newMenuBar
|
|
, Menu(..)
|
|
, FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..)
|
|
, ResourceType(..)
|
|
, MenuItem(..)
|
|
, createMenuBar
|
|
)
|
|
where
|
|
|
|
-- base
|
|
import Control.Monad
|
|
( void, unless )
|
|
import Data.Foldable
|
|
( for_ )
|
|
import Data.Kind
|
|
( Type )
|
|
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
|
|
import qualified GI.Gdk as GDK
|
|
|
|
-- gi-gtk
|
|
import qualified GI.Gtk as GTK
|
|
|
|
-- text
|
|
import Data.Text
|
|
( Text )
|
|
|
|
-- transformers
|
|
import Control.Monad.IO.Class
|
|
( MonadIO(liftIO) )
|
|
|
|
-- MetaBrush
|
|
import MetaBrush.Asset.Colours
|
|
( Colours )
|
|
import MetaBrush.Asset.WindowIcons
|
|
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
|
import MetaBrush.Render.Util
|
|
( widgetAddClass, widgetAddClasses )
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Types for describing menu items.
|
|
|
|
data ResourceType
|
|
= Description
|
|
| Object
|
|
|
|
data family MenuItem ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
|
|
data instance MenuItem submenu Description
|
|
= MenuItemDescription
|
|
{ menuItemLabel :: !Text
|
|
, menuItemClasses :: ![ Text ]
|
|
, menuItemAction :: !( Maybe Text )
|
|
, submenuDescription :: !( submenu Description )
|
|
}
|
|
data instance MenuItem submenu Object
|
|
= MenuItem
|
|
{ menuItem :: !GTK.MenuItem
|
|
, menuItemSubmenu :: !( submenu Object )
|
|
}
|
|
|
|
data family Separator ( r :: ResourceType )
|
|
data instance Separator Description
|
|
= SeparatorDescription
|
|
{ separatorClasses :: ![ Text ] }
|
|
data instance Separator Object
|
|
= Separator
|
|
{ separatorItem :: !GTK.MenuItem }
|
|
|
|
data NoSubresource ( k :: ResourceType ) = NoSubresource
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Menu used in MetaBrush.
|
|
|
|
-- Types.
|
|
|
|
data Menu ( rt :: ResourceType )
|
|
= Menu
|
|
{ file :: !( MenuItem FileMenu rt )
|
|
, edit :: !( MenuItem EditMenu rt )
|
|
, view :: !( MenuItem ViewMenu rt )
|
|
, help :: !( MenuItem HelpMenu rt )
|
|
}
|
|
deriving stock Generic
|
|
|
|
data FileMenu ( rt :: ResourceType )
|
|
= FileMenu
|
|
{ new :: !( MenuItem NoSubresource rt )
|
|
, open :: !( MenuItem NoSubresource rt )
|
|
, save :: !( MenuItem NoSubresource rt )
|
|
, saveAs :: !( MenuItem NoSubresource rt )
|
|
, close :: !( MenuItem NoSubresource rt )
|
|
, quit :: !( MenuItem NoSubresource rt )
|
|
}
|
|
deriving stock Generic
|
|
|
|
data EditMenu ( rt :: ResourceType )
|
|
= EditMenu
|
|
{ undo :: !( MenuItem NoSubresource rt )
|
|
, redo :: !( MenuItem NoSubresource rt )
|
|
, history :: !( MenuItem NoSubresource rt )
|
|
, editSep1 :: !( Separator rt )
|
|
, cut :: !( MenuItem NoSubresource rt )
|
|
, copy :: !( MenuItem NoSubresource rt )
|
|
, paste :: !( MenuItem NoSubresource rt )
|
|
, duplicate :: !( MenuItem NoSubresource rt )
|
|
, delete :: !( MenuItem NoSubresource rt )
|
|
, editSep2 :: !( Separator rt )
|
|
, preferences :: !( MenuItem NoSubresource rt )
|
|
}
|
|
deriving stock Generic
|
|
|
|
data ViewMenu ( rt :: ResourceType )
|
|
= ViewMenu
|
|
{ navigator :: !( 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 )
|
|
}
|
|
deriving stock Generic
|
|
|
|
data HelpMenu ( rt :: ResourceType )
|
|
= HelpMenu
|
|
{ about :: !( MenuItem 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" ] 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
|
|
}
|
|
|
|
editMenuDescription :: EditMenu Description
|
|
editMenuDescription
|
|
= EditMenu
|
|
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Nothing NoSubresource
|
|
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing NoSubresource
|
|
, history = MenuItemDescription "History" [ "submenuItem" ] Nothing 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
|
|
, editSep2 = SeparatorDescription [ "submenuSeparator" ]
|
|
, preferences = MenuItemDescription "Preferences" [ "submenuItem" ] Nothing NoSubresource
|
|
}
|
|
|
|
viewMenuDescription :: ViewMenu Description
|
|
viewMenuDescription
|
|
= ViewMenu
|
|
{ navigator = MenuItemDescription "Navigator" [ "submenuItem" ] Nothing 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
|
|
}
|
|
|
|
helpMenuDescription :: HelpMenu Description
|
|
helpMenuDescription
|
|
= HelpMenu
|
|
{ about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] Nothing NoSubresource }
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Creating a GTK menu bar from a menu description.
|
|
|
|
newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem
|
|
newMenuItem ( MenuItemDescription { .. } ) = do
|
|
menuItem <- GTK.menuItemNewWithLabel menuItemLabel
|
|
-- Could set accelerator labels...
|
|
unless ( null menuItemClasses ) do
|
|
widgetAddClasses menuItem menuItemClasses
|
|
for_ menuItemAction \ actionName -> do
|
|
GTK.actionableSetActionName menuItem ( Just actionName )
|
|
pure menuItem
|
|
|
|
class CreateMenuItem desc res | desc -> res, res -> desc where
|
|
createMenuItem :: MonadIO m => ( GTK.MenuItem -> m () ) -> desc -> m res
|
|
instance {-# OVERLAPPING #-} CreateMenuItem ( MenuItem NoSubresource Description ) ( MenuItem NoSubresource Object ) where
|
|
createMenuItem attachToParent menuItemDescription = do
|
|
menuItem <- newMenuItem menuItemDescription
|
|
attachToParent menuItem
|
|
pure
|
|
MenuItem
|
|
{ menuItem = menuItem
|
|
, menuItemSubmenu = NoSubresource
|
|
}
|
|
instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
|
|
=> CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object )
|
|
where
|
|
createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
|
|
menuItem <- newMenuItem menuItemDescription
|
|
submenu <- GTK.menuNew
|
|
submenuItems <-
|
|
constraints @CreateMenuItem
|
|
( createMenuItem ( 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 => m ( GTK.MenuBar, Menu Object )
|
|
newMenuBar = do
|
|
menuBar <- GTK.menuBarNew
|
|
menu <-
|
|
constraints @CreateMenuItem
|
|
( createMenuItem ( 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).
|
|
createMenuBar :: Colours -> GTK.Window -> GTK.Box -> IO ( Menu Object )
|
|
createMenuBar colours window titleBar = do
|
|
( menuBar, menu ) <- newMenuBar
|
|
widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
|
|
GTK.boxPackStart titleBar menuBar False False 0
|
|
|
|
-- 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
|
|
for_ topLevelMenuItems \ topLevelMenuItem -> do
|
|
void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
|
|
flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
|
GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
|
|
pure False
|
|
void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
|
|
flags <- GTK.widgetGetStateFlags topLevelMenuItem
|
|
GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
|
|
pure False
|
|
|
|
windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
|
|
widgetAddClasses windowIcons [ "windowIcon" ]
|
|
GTK.boxPackEnd titleBar windowIcons False False 0
|
|
|
|
minimiseButton <- GTK.buttonNew
|
|
fullscreenButton <- GTK.buttonNew
|
|
closeButton <- GTK.buttonNew
|
|
|
|
GTK.boxPackStart windowIcons minimiseButton True True 0
|
|
GTK.boxPackStart windowIcons fullscreenButton True True 0
|
|
GTK.boxPackStart windowIcons closeButton True True 0
|
|
|
|
minimiseArea <- GTK.drawingAreaNew
|
|
fullscreenArea <- GTK.drawingAreaNew
|
|
closeArea <- GTK.drawingAreaNew
|
|
|
|
GTK.containerAdd minimiseButton minimiseArea
|
|
GTK.containerAdd fullscreenButton fullscreenArea
|
|
GTK.containerAdd closeButton closeArea
|
|
|
|
void $ GTK.onWidgetDraw minimiseArea
|
|
$ Cairo.renderWithContext
|
|
( drawMinimise colours )
|
|
|
|
void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do
|
|
Just gdkWindow <- GTK.widgetGetWindow window
|
|
windowState <- GDK.windowGetState gdkWindow
|
|
if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState
|
|
then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
|
|
else Cairo.renderWithContext ( drawMaximise colours ) cairoContext
|
|
|
|
void $ GTK.onWidgetDraw closeArea
|
|
$ Cairo.renderWithContext
|
|
( drawClose colours )
|
|
|
|
for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do
|
|
widgetAddClass button "windowIcon"
|
|
|
|
widgetAddClass closeButton "closeWindowIcon"
|
|
|
|
---------------------------------------------------------
|
|
-- Actions
|
|
|
|
_ <- GTK.onButtonClicked closeButton GTK.mainQuit
|
|
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window )
|
|
_ <- GTK.onButtonClicked fullscreenButton do
|
|
Just gdkWindow <- GTK.widgetGetWindow window
|
|
windowState <- GDK.windowGetState gdkWindow
|
|
if GDK.WindowStateFullscreen `elem` windowState
|
|
then GTK.windowUnfullscreen window
|
|
else
|
|
if GDK.WindowStateMaximized `elem` windowState
|
|
then GTK.windowUnmaximize window
|
|
else GTK.windowMaximize window
|
|
|
|
---------------------------------------------------------
|
|
|
|
pure menu
|