hook up menu to actions, + some refactors

This commit is contained in:
sheaf 2020-09-02 22:49:50 +02:00
parent 919acf4928
commit db4115c634
10 changed files with 373 additions and 240 deletions

View file

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

View file

@ -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
uiElements :: UIElements
uiElements = UIElements { .. }
handleEvents uiElements actionTQueue
void $ GDK.threadsAddIdle 200 ( handleActions actionTQueue uiElements variables )
handleEvents uiElements variables
---------------------------------------------------------
-- GTK main loop

View file

@ -1,19 +1,22 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module MetaBrush.Action
( Actions, HandleAction(..)
, handleActions, signalAction, quitEverything
( HandleAction(..)
, 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
handleActions actionTQueue elts vars = do
--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
instance HandleAction () where
handleAction _ _ _ = pure ()
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
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 ()
GDK.KEY_Return -> handleAction uiElts vars Confirm
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 ()
----------------------

View file

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

View file

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

View file

@ -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 { window, viewportDrawingArea } ) actionTQueue = do
handleEvents :: UIElements -> Variables -> IO ()
handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do
-- Mouse events
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent actionTQueue )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent actionTQueue )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent actionTQueue )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease actionTQueue )
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent elts vars )
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent elts vars )
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent elts vars )
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
-- Keyboard events
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent actionTQueue )
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue )
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
_ <- 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 actionTQueue eventMotion = do
handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool
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 actionTQueue scrollEvent = do
handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool
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 actionTQueue mouseClickEvent = do
handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool
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 actionTQueue mouseReleaseEvent = do
handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool
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 actionTQueue evt = do
handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
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 actionTQueue evt = do
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent elts vars evt = do
keyCode <- GDK.getEventKeyKeyval evt
STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode )
handleAction elts vars ( KeyboardRelease keyCode )
pure True

View file

@ -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
GTK.widgetQueueDraw viewportArea
updateInfoBar viewportDrawingArea infoBar vars
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

View file

@ -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
:: Variables
-> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
-> Maybe Document
-> TabLocation
-> IO ()
newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO ()

View file

@ -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 instance MenuItem submenu Description
data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
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 )
, edit :: !( MenuItem EditMenu rt )
, view :: !( MenuItem ViewMenu rt )
, help :: !( MenuItem HelpMenu rt )
{ 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, 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 )
, editSep1 :: !( Separator rt )
, cut, copy, paste, duplicate, delete :: !( MenuItem NoSubresource rt )
, editSep2 :: !( Separator rt )
, preferences :: !( MenuItem NoSubresource rt )
{ undo :: !( MenuItem Undo NoSubresource rt )
, redo :: !( MenuItem Redo NoSubresource rt )
, editSep1 :: !( Separator 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 )
}
deriving stock Generic
data ViewMenu ( rt :: ResourceType )
= ViewMenu
{ navigator :: !( MenuItem NoSubresource rt )
, viewSep1 :: !( Separator rt )
, strokes, brushes, metaparameters :: !( MenuItem NoSubresource rt )
, viewSep2 :: !( Separator rt )
, transform :: !( MenuItem NoSubresource rt )
{ navigator :: !( MenuItem () NoSubresource rt )
, history :: !( 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 ) }
{ 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
, edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing Nothing editMenuDescription
, view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing Nothing viewMenuDescription
, help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing Nothing helpMenuDescription
{ 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 ( 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
{ new = MenuItemDescription "New" [ "submenuItem" ] ( NewFile AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
, open = MenuItemDescription "Open" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
, save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
, saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
, close = MenuItemDescription "Close" [ "submenuItem" ] Close ( Just ( GDK.KEY_W, [ 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
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
, history = MenuItemDescription "History" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_H, [ Control L ] ) ) NoSubresource
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Undo ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Redo ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
, editSep1 = SeparatorDescription [ "submenuSeparator" ]
, 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
, cut = MenuItemDescription "Cut" [ "submenuItem" ] Cut ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
, copy = MenuItemDescription "Copy" [ "submenuItem" ] Copy ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
, paste = MenuItemDescription "Paste" [ "submenuItem" ] Paste ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
, duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Duplicate ( Just ( GDK.KEY_D, [ Control L ] ) ) 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
, brushes = MenuItemDescription "Brushes" [ "submenuItem" ] Nothing Nothing NoSubresource
, metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] Nothing Nothing NoSubresource
, 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 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 ( MenuItemDescription { .. } ) = do
newMenuItem
:: ( 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 ) )
for_ mbAccelLabel \ accelLabel -> do
GTK.accelLabelSetAccel accelLabel key ( map modifierType modifiers )
widgetAddClass accelLabel "accelLabel"
GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel"
unless ( null menuItemClasses ) do
widgetAddClasses menuItem menuItemClasses
for_ menuItemAction \ actionName -> do
GTK.actionableSetActionName menuItem ( Just actionName )
void $ GTK.onMenuItemActivate menuItem
( handleAction uiElts vars menuItemAction )
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
createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res
instance {-# OVERLAPPING #-}
HandleAction action
=> 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 ) )
=> CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object )
instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
=> CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object )
where
createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
menuItem <- newMenuItem menuItemDescription
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
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 = do
newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
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 colours window titleBar = do
( menuBar, menu ) <- newMenuBar
createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
createMenuBar uiElts@( UIElements { titleBar, window } ) vars colours = do
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

View file

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