mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-23 15:34:06 +00:00
hook up menu to actions, + some refactors
This commit is contained in:
sheaf
parent
919acf4928
commit
db4115c634
|
|
@ -150,8 +150,6 @@ executable MetaBrush
|
|||
^>= 0.0.1
|
||||
, haskell-gi-base
|
||||
^>= 0.24
|
||||
, haskus-utils-variant
|
||||
^>= 3.0
|
||||
, lens
|
||||
^>= 4.19.2
|
||||
, scientific
|
||||
|
|
|
|||
34
app/Main.hs
34
app/Main.hs
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
||||
----------------------
|
||||
|
|
|
|||
|
|
@ -60,6 +60,7 @@ data UIElements
|
|||
= UIElements
|
||||
{ window :: !GTK.Window
|
||||
, title :: !GTK.Label
|
||||
, titleBar :: !GTK.Box
|
||||
, fileBar :: !FileBar
|
||||
, viewportDrawingArea :: !GTK.DrawingArea
|
||||
, infoBar :: !InfoBar
|
||||
|
|
|
|||
|
|
@ -5,7 +5,6 @@
|
|||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ) )
|
||||
|
|
|
|||
Loading…
Reference in a new issue