mirror of
https://gitlab.com/sheaf/metabrush.git
synced 2024-11-27 09:24:08 +00:00
hook up menu to actions, + some refactors
This commit is contained in:
parent
919acf4928
commit
db4115c634
|
@ -150,8 +150,6 @@ executable MetaBrush
|
||||||
^>= 0.0.1
|
^>= 0.0.1
|
||||||
, haskell-gi-base
|
, haskell-gi-base
|
||||||
^>= 0.24
|
^>= 0.24
|
||||||
, haskus-utils-variant
|
|
||||||
^>= 3.0
|
|
||||||
, lens
|
, lens
|
||||||
^>= 4.19.2
|
^>= 4.19.2
|
||||||
, scientific
|
, scientific
|
||||||
|
|
34
app/Main.hs
34
app/Main.hs
|
@ -44,15 +44,9 @@ import qualified GI.Gdk as GDK
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- haskus-utils-variant
|
|
||||||
import Haskus.Utils.Variant
|
|
||||||
( V )
|
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import qualified Control.Concurrent.STM as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
( atomically )
|
( atomically )
|
||||||
import qualified Control.Concurrent.STM.TQueue as STM
|
|
||||||
( newTQueueIO )
|
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM.TVar as STM
|
||||||
( newTVarIO, readTVar )
|
( newTVarIO, readTVar )
|
||||||
|
|
||||||
|
@ -65,8 +59,6 @@ import Math.Bezier.Stroke
|
||||||
( StrokePoint(..) )
|
( StrokePoint(..) )
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D(..) )
|
( Point2D(..) )
|
||||||
import MetaBrush.Action
|
|
||||||
( Actions, handleActions )
|
|
||||||
import MetaBrush.Asset.Brushes
|
import MetaBrush.Asset.Brushes
|
||||||
( ellipse, rect )
|
( ellipse, rect )
|
||||||
import MetaBrush.Asset.Colours
|
import MetaBrush.Asset.Colours
|
||||||
|
@ -201,8 +193,6 @@ main = do
|
||||||
variables :: Variables
|
variables :: Variables
|
||||||
variables = Variables { .. }
|
variables = Variables { .. }
|
||||||
|
|
||||||
actionTQueue <- STM.newTQueueIO @( V Actions )
|
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Initialise GTK
|
-- Initialise GTK
|
||||||
|
|
||||||
|
@ -289,11 +279,6 @@ main = do
|
||||||
void $ GTK.onWidgetDraw logoArea
|
void $ GTK.onWidgetDraw logoArea
|
||||||
$ Cairo.renderWithContext ( drawLogo colours )
|
$ Cairo.renderWithContext ( drawLogo colours )
|
||||||
|
|
||||||
------------
|
|
||||||
-- Menu bar
|
|
||||||
|
|
||||||
_ <- createMenuBar colours window titleBar
|
|
||||||
|
|
||||||
------------
|
------------
|
||||||
-- Title
|
-- Title
|
||||||
|
|
||||||
|
@ -345,12 +330,21 @@ main = do
|
||||||
fileBar@( FileBar { fileBarBox } ) <-
|
fileBar@( FileBar { fileBarBox } ) <-
|
||||||
createFileBar
|
createFileBar
|
||||||
variables
|
variables
|
||||||
window title viewportDrawingArea infoBar
|
window titleBar title viewportDrawingArea infoBar
|
||||||
|
|
||||||
GTK.boxPackStart mainView fileBarBox False False 0
|
GTK.boxPackStart mainView fileBarBox False False 0
|
||||||
GTK.boxPackStart mainView viewportGrid True True 0
|
GTK.boxPackStart mainView viewportGrid True True 0
|
||||||
GTK.boxPackStart mainView infoBarArea False False 0
|
GTK.boxPackStart mainView infoBarArea False False 0
|
||||||
|
|
||||||
|
let
|
||||||
|
uiElements :: UIElements
|
||||||
|
uiElements = UIElements { .. }
|
||||||
|
|
||||||
|
------------
|
||||||
|
-- Menu bar
|
||||||
|
|
||||||
|
_ <- createMenuBar uiElements variables colours
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Panels
|
-- Panels
|
||||||
|
|
||||||
|
@ -359,13 +353,7 @@ main = do
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- Actions
|
-- Actions
|
||||||
|
|
||||||
let
|
handleEvents uiElements variables
|
||||||
uiElements :: UIElements
|
|
||||||
uiElements = UIElements { .. }
|
|
||||||
|
|
||||||
handleEvents uiElements actionTQueue
|
|
||||||
|
|
||||||
void $ GDK.threadsAddIdle 200 ( handleActions actionTQueue uiElements variables )
|
|
||||||
|
|
||||||
---------------------------------------------------------
|
---------------------------------------------------------
|
||||||
-- GTK main loop
|
-- GTK main loop
|
||||||
|
|
|
@ -1,19 +1,22 @@
|
||||||
{-# LANGUAGE BangPatterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
|
||||||
|
|
||||||
module MetaBrush.Action
|
module MetaBrush.Action
|
||||||
( Actions, HandleAction(..)
|
( HandleAction(..)
|
||||||
, handleActions, signalAction, quitEverything
|
, quitEverything
|
||||||
|
, NewFile(..), OpenFile(..), Save(..), SaveAs(..), Close(..), Quit(..)
|
||||||
|
, Undo(..), Redo(..), Cut(..), Copy(..), Paste(..), Duplicate(..), Delete(..)
|
||||||
|
, Confirm(..)
|
||||||
|
, About(..)
|
||||||
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
||||||
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
||||||
)
|
)
|
||||||
|
@ -23,7 +26,7 @@ module MetaBrush.Action
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
( guard, unless, void )
|
( guard, unless, void )
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
( for_, traverse_ )
|
( for_ )
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
( catMaybes )
|
( catMaybes )
|
||||||
import Data.Word
|
import Data.Word
|
||||||
|
@ -38,8 +41,6 @@ import Data.Act
|
||||||
)
|
)
|
||||||
|
|
||||||
-- containers
|
-- containers
|
||||||
import qualified Data.Map as Map
|
|
||||||
( lookup )
|
|
||||||
import Data.Sequence
|
import Data.Sequence
|
||||||
( Seq(..) )
|
( Seq(..) )
|
||||||
import qualified Data.Sequence as Seq
|
import qualified Data.Sequence as Seq
|
||||||
|
@ -53,19 +54,9 @@ import qualified GI.Gdk as GDK
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as GTK
|
import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- haskus-utils-variant
|
|
||||||
import Haskus.Utils.Variant
|
|
||||||
( V, pattern V, ReduceVariant, reduceVariant
|
|
||||||
, type (:<)
|
|
||||||
)
|
|
||||||
|
|
||||||
-- stm
|
-- stm
|
||||||
import Control.Concurrent.STM
|
|
||||||
( STM )
|
|
||||||
import qualified Control.Concurrent.STM as STM
|
import qualified Control.Concurrent.STM as STM
|
||||||
( atomically )
|
( atomically )
|
||||||
import qualified Control.Concurrent.STM.TQueue as STM
|
|
||||||
( TQueue, flushTQueue, writeTQueue )
|
|
||||||
import qualified Control.Concurrent.STM.TVar as STM
|
import qualified Control.Concurrent.STM.TVar as STM
|
||||||
( readTVar, readTVarIO, swapTVar, modifyTVar', writeTVar )
|
( 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
|
class HandleAction action where
|
||||||
handleAction :: UIElements -> Variables -> action -> IO ()
|
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
|
instance HandleAction () where
|
||||||
handleActions actionTQueue elts vars = do
|
handleAction _ _ _ = pure ()
|
||||||
--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
|
|
||||||
|
|
||||||
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 --
|
-- Quitting --
|
||||||
--------------
|
--------------
|
||||||
|
|
||||||
|
data Quit = Quit
|
||||||
|
deriving stock Show
|
||||||
|
|
||||||
|
instance HandleAction Quit where
|
||||||
|
handleAction ( UIElements { window } ) _ _ = quitEverything window
|
||||||
|
|
||||||
quitEverything :: GTK.Window -> IO ()
|
quitEverything :: GTK.Window -> IO ()
|
||||||
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit
|
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 --
|
-- Mouse movement --
|
||||||
--------------------
|
--------------------
|
||||||
|
@ -452,9 +613,9 @@ data KeyboardPress = KeyboardPress Word32
|
||||||
deriving stock Show
|
deriving stock Show
|
||||||
|
|
||||||
instance HandleAction KeyboardPress where
|
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
|
!modifiers <- STM.readTVar modifiersTVar
|
||||||
for_ ( modifierKey keyCode ) \ modifier ->
|
for_ ( modifierKey keyCode ) \ modifier ->
|
||||||
( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
|
( STM.writeTVar modifiersTVar ( Set.insert modifier modifiers ) )
|
||||||
|
@ -462,26 +623,9 @@ instance HandleAction KeyboardPress where
|
||||||
|
|
||||||
case keyCode of
|
case keyCode of
|
||||||
|
|
||||||
GDK.KEY_Escape -> quitEverything window
|
GDK.KEY_Escape -> handleAction uiElts vars Quit
|
||||||
|
|
||||||
GDK.KEY_Return -> do
|
GDK.KEY_Return -> handleAction uiElts vars Confirm
|
||||||
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 ()
|
|
||||||
|
|
||||||
ctrl
|
ctrl
|
||||||
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
|
| ctrl == GDK.KEY_Control_L || ctrl == GDK.KEY_Control_R
|
||||||
|
@ -501,24 +645,6 @@ instance HandleAction KeyboardPress where
|
||||||
GTK.widgetQueueDraw viewportDrawingArea
|
GTK.widgetQueueDraw viewportDrawingArea
|
||||||
_ -> pure ()
|
_ -> 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 ()
|
_ -> pure ()
|
||||||
|
|
||||||
----------------------
|
----------------------
|
||||||
|
|
|
@ -60,6 +60,7 @@ data UIElements
|
||||||
= UIElements
|
= UIElements
|
||||||
{ window :: !GTK.Window
|
{ window :: !GTK.Window
|
||||||
, title :: !GTK.Label
|
, title :: !GTK.Label
|
||||||
|
, titleBar :: !GTK.Box
|
||||||
, fileBar :: !FileBar
|
, fileBar :: !FileBar
|
||||||
, viewportDrawingArea :: !GTK.DrawingArea
|
, viewportDrawingArea :: !GTK.DrawingArea
|
||||||
, infoBar :: !InfoBar
|
, infoBar :: !InfoBar
|
||||||
|
|
|
@ -5,7 +5,6 @@
|
||||||
{-# LANGUAGE FlexibleInstances #-}
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
{-# LANGUAGE LambdaCase #-}
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE NamedFieldPuns #-}
|
{-# LANGUAGE NamedFieldPuns #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
|
|
|
@ -6,48 +6,38 @@ module MetaBrush.Event
|
||||||
( handleEvents )
|
( handleEvents )
|
||||||
where
|
where
|
||||||
|
|
||||||
-- haskus-utils-variant
|
|
||||||
import Haskus.Utils.Variant
|
|
||||||
( V, type (:<), type (:<<) )
|
|
||||||
|
|
||||||
-- gi-gdk
|
-- gi-gdk
|
||||||
import qualified GI.Gdk as GDK
|
import qualified GI.Gdk as GDK
|
||||||
|
|
||||||
-- gi-gtk
|
-- gi-gtk
|
||||||
import qualified GI.Gtk as 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
|
-- MetaBrush
|
||||||
import Math.Vector2D
|
import Math.Vector2D
|
||||||
( Point2D(..), Vector2D(..) )
|
( Point2D(..), Vector2D(..) )
|
||||||
import MetaBrush.Action
|
import MetaBrush.Action
|
||||||
( Actions
|
( HandleAction(..)
|
||||||
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
, MouseMove(..), MouseClick(..), MouseRelease(..)
|
||||||
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
, Scroll(..), KeyboardPress(..), KeyboardRelease(..)
|
||||||
, signalAction, quitEverything
|
, quitEverything
|
||||||
)
|
)
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( UIElements(..) )
|
( UIElements(..), Variables(..) )
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
handleEvents :: Actions :<< action => UIElements -> STM.TQueue ( V action ) -> IO ()
|
handleEvents :: UIElements -> Variables -> IO ()
|
||||||
handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do
|
handleEvents elts@( UIElements { window, viewportDrawingArea } ) vars = do
|
||||||
|
|
||||||
-- Mouse events
|
-- Mouse events
|
||||||
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent actionTQueue )
|
_ <- GTK.onWidgetMotionNotifyEvent viewportDrawingArea ( handleMotionEvent elts vars )
|
||||||
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent actionTQueue )
|
_ <- GTK.onWidgetScrollEvent viewportDrawingArea ( handleScrollEvent elts vars )
|
||||||
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent actionTQueue )
|
_ <- GTK.onWidgetButtonPressEvent viewportDrawingArea ( handleMouseButtonEvent elts vars )
|
||||||
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease actionTQueue )
|
_ <- GTK.onWidgetButtonReleaseEvent viewportDrawingArea ( handleMouseButtonRelease elts vars )
|
||||||
|
|
||||||
-- Keyboard events
|
-- Keyboard events
|
||||||
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent actionTQueue )
|
_ <- GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars )
|
||||||
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent actionTQueue )
|
_ <- GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars )
|
||||||
|
|
||||||
-- Window quit
|
-- Window quit
|
||||||
_ <- GTK.onWidgetDestroy window ( quitEverything window )
|
_ <- GTK.onWidgetDestroy window ( quitEverything window )
|
||||||
|
@ -57,49 +47,49 @@ handleEvents ( UIElements { window, viewportDrawingArea } ) actionTQueue = do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Mouse events.
|
-- Mouse events.
|
||||||
|
|
||||||
handleMotionEvent :: MouseMove :< action => STM.TQueue ( V action ) -> GDK.EventMotion -> IO Bool
|
handleMotionEvent :: UIElements -> Variables -> GDK.EventMotion -> IO Bool
|
||||||
handleMotionEvent actionTQueue eventMotion = do
|
handleMotionEvent elts vars eventMotion = do
|
||||||
x <- GDK.getEventMotionX eventMotion
|
x <- GDK.getEventMotionX eventMotion
|
||||||
y <- GDK.getEventMotionY eventMotion
|
y <- GDK.getEventMotionY eventMotion
|
||||||
STM.atomically $ signalAction actionTQueue ( MouseMove ( Point2D x y ) )
|
handleAction elts vars ( MouseMove ( Point2D x y ) )
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
handleScrollEvent :: Scroll :< action => STM.TQueue ( V action ) -> GDK.EventScroll -> IO Bool
|
handleScrollEvent :: UIElements -> Variables -> GDK.EventScroll -> IO Bool
|
||||||
handleScrollEvent actionTQueue scrollEvent = do
|
handleScrollEvent elts vars scrollEvent = do
|
||||||
dx <- GDK.getEventScrollDeltaX scrollEvent
|
dx <- GDK.getEventScrollDeltaX scrollEvent
|
||||||
dy <- GDK.getEventScrollDeltaY scrollEvent
|
dy <- GDK.getEventScrollDeltaY scrollEvent
|
||||||
x <- GDK.getEventScrollX scrollEvent
|
x <- GDK.getEventScrollX scrollEvent
|
||||||
y <- GDK.getEventScrollY 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
|
pure False
|
||||||
|
|
||||||
handleMouseButtonEvent :: MouseClick :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
|
handleMouseButtonEvent :: UIElements -> Variables -> GDK.EventButton -> IO Bool
|
||||||
handleMouseButtonEvent actionTQueue mouseClickEvent = do
|
handleMouseButtonEvent elts vars mouseClickEvent = do
|
||||||
button <- GDK.getEventButtonButton mouseClickEvent
|
button <- GDK.getEventButtonButton mouseClickEvent
|
||||||
x <- GDK.getEventButtonX mouseClickEvent
|
x <- GDK.getEventButtonX mouseClickEvent
|
||||||
y <- GDK.getEventButtonY mouseClickEvent
|
y <- GDK.getEventButtonY mouseClickEvent
|
||||||
STM.atomically $ signalAction actionTQueue ( MouseClick button ( Point2D x y ) )
|
handleAction elts vars ( MouseClick button ( Point2D x y ) )
|
||||||
pure False
|
pure False
|
||||||
|
|
||||||
handleMouseButtonRelease :: MouseRelease :< action => STM.TQueue ( V action ) -> GDK.EventButton -> IO Bool
|
handleMouseButtonRelease :: UIElements -> Variables -> GDK.EventButton -> IO Bool
|
||||||
handleMouseButtonRelease actionTQueue mouseReleaseEvent = do
|
handleMouseButtonRelease elts vars mouseReleaseEvent = do
|
||||||
button <- GDK.getEventButtonButton mouseReleaseEvent
|
button <- GDK.getEventButtonButton mouseReleaseEvent
|
||||||
x <- GDK.getEventButtonX mouseReleaseEvent
|
x <- GDK.getEventButtonX mouseReleaseEvent
|
||||||
y <- GDK.getEventButtonY mouseReleaseEvent
|
y <- GDK.getEventButtonY mouseReleaseEvent
|
||||||
STM.atomically $ signalAction actionTQueue ( MouseRelease button ( Point2D x y ) )
|
handleAction elts vars ( MouseRelease button ( Point2D x y ) )
|
||||||
pure False
|
pure False
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Keyboard events.
|
-- Keyboard events.
|
||||||
|
|
||||||
handleKeyboardPressEvent :: KeyboardPress :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
|
handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
||||||
handleKeyboardPressEvent actionTQueue evt = do
|
handleKeyboardPressEvent elts vars evt = do
|
||||||
keyCode <- GDK.getEventKeyKeyval evt
|
keyCode <- GDK.getEventKeyKeyval evt
|
||||||
STM.atomically $ signalAction actionTQueue ( KeyboardPress keyCode )
|
handleAction elts vars ( KeyboardPress keyCode )
|
||||||
pure True
|
pure True
|
||||||
|
|
||||||
handleKeyboardReleaseEvent :: KeyboardRelease :< action => STM.TQueue ( V action ) -> GDK.EventKey -> IO Bool
|
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
|
||||||
handleKeyboardReleaseEvent actionTQueue evt = do
|
handleKeyboardReleaseEvent elts vars evt = do
|
||||||
keyCode <- GDK.getEventKeyKeyval evt
|
keyCode <- GDK.getEventKeyKeyval evt
|
||||||
STM.atomically $ signalAction actionTQueue ( KeyboardRelease keyCode )
|
handleAction elts vars ( KeyboardRelease keyCode )
|
||||||
pure True
|
pure True
|
||||||
|
|
|
@ -38,7 +38,7 @@ import Data.Text
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( Variables(..) )
|
( UIElements(..), Variables(..) )
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document(..), emptyDocument )
|
( Document(..), emptyDocument )
|
||||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||||
|
@ -66,13 +66,13 @@ data TabLocation
|
||||||
|
|
||||||
newFileTab
|
newFileTab
|
||||||
:: Variables
|
:: Variables
|
||||||
-> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
|
-> UIElements
|
||||||
-> Maybe Document
|
-> Maybe Document
|
||||||
-> TabLocation
|
-> TabLocation
|
||||||
-> IO ()
|
-> IO ()
|
||||||
newFileTab
|
newFileTab
|
||||||
vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } )
|
vars@( Variables { uniqueSupply, activeDocumentTVar, openDocumentsTVar } )
|
||||||
window title ( FileBar { fileTabsBox, fileBarPhantomRadioButton } ) viewportArea infoBar
|
( UIElements { fileBar = FileBar {..}, .. } )
|
||||||
mbDoc
|
mbDoc
|
||||||
newTabLoc
|
newTabLoc
|
||||||
= do
|
= do
|
||||||
|
@ -140,7 +140,7 @@ newFileTab
|
||||||
STM.atomically do
|
STM.atomically do
|
||||||
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
|
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDoc )
|
||||||
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
STM.writeTVar activeDocumentTVar ( Just newUnique )
|
||||||
GTK.widgetQueueDraw viewportArea
|
GTK.widgetQueueDraw viewportDrawingArea
|
||||||
|
|
||||||
void $ GTK.onButtonClicked pgButton do
|
void $ GTK.onButtonClicked pgButton do
|
||||||
isActive <- GTK.toggleButtonGetActive pgButton
|
isActive <- GTK.toggleButtonGetActive pgButton
|
||||||
|
@ -164,13 +164,16 @@ newFileTab
|
||||||
= displayName <> " – MetaBrush"
|
= displayName <> " – MetaBrush"
|
||||||
GTK.labelSetText title titleText
|
GTK.labelSetText title titleText
|
||||||
GTK.setWindowTitle window titleText
|
GTK.setWindowTitle window titleText
|
||||||
updateInfoBar viewportArea infoBar vars
|
updateInfoBar viewportDrawingArea infoBar vars
|
||||||
GTK.widgetQueueDraw viewportArea
|
GTK.widgetQueueDraw viewportDrawingArea
|
||||||
else do
|
else do
|
||||||
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True
|
||||||
GTK.labelSetText title "MetaBrush"
|
GTK.labelSetText title "MetaBrush"
|
||||||
GTK.setWindowTitle window "MetaBrush"
|
GTK.setWindowTitle window "MetaBrush"
|
||||||
|
|
||||||
|
--void $ GTK.onButtonClicked closeFileButton
|
||||||
|
-- ( STM.atomically $ signalAction actionTQueue Close )
|
||||||
|
|
||||||
--void $ GTK.onButtonClicked closeFileButton ... ... ...
|
--void $ GTK.onButtonClicked closeFileButton ... ... ...
|
||||||
|
|
||||||
GTK.toggleButtonSetActive pgButton True
|
GTK.toggleButtonSetActive pgButton True
|
||||||
|
@ -180,11 +183,11 @@ newFileTab
|
||||||
-- Updates the active document when buttons are clicked.
|
-- Updates the active document when buttons are clicked.
|
||||||
createFileBar
|
createFileBar
|
||||||
:: Variables
|
:: Variables
|
||||||
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
||||||
-> IO FileBar
|
-> IO FileBar
|
||||||
createFileBar
|
createFileBar
|
||||||
vars@( Variables { openDocumentsTVar } )
|
vars@( Variables { openDocumentsTVar } )
|
||||||
window title viewportArea infoBar
|
window titleBar title viewportDrawingArea infoBar
|
||||||
= do
|
= do
|
||||||
|
|
||||||
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
-- Create file bar: box containing scrollable tabs, and a "+" button after it.
|
||||||
|
@ -211,19 +214,21 @@ createFileBar
|
||||||
let
|
let
|
||||||
fileBar :: FileBar
|
fileBar :: FileBar
|
||||||
fileBar = FileBar { .. }
|
fileBar = FileBar { .. }
|
||||||
|
uiElements :: UIElements
|
||||||
|
uiElements = UIElements { .. }
|
||||||
|
|
||||||
documents <- STM.readTVarIO openDocumentsTVar
|
documents <- STM.readTVarIO openDocumentsTVar
|
||||||
for_ documents \ doc ->
|
for_ documents \ doc ->
|
||||||
newFileTab
|
newFileTab
|
||||||
vars
|
vars
|
||||||
window title fileBar viewportArea infoBar
|
uiElements
|
||||||
( Just doc )
|
( Just doc )
|
||||||
LastTab
|
LastTab
|
||||||
|
|
||||||
void $ GTK.onButtonClicked newFileButton do
|
void $ GTK.onButtonClicked newFileButton do
|
||||||
newFileTab
|
newFileTab
|
||||||
vars
|
vars
|
||||||
window title fileBar viewportArea infoBar
|
uiElements
|
||||||
Nothing
|
Nothing
|
||||||
LastTab
|
LastTab
|
||||||
|
|
||||||
|
|
|
@ -9,7 +9,7 @@ import qualified GI.Gtk as GTK
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import {-# SOURCE #-} MetaBrush.Context
|
import {-# SOURCE #-} MetaBrush.Context
|
||||||
( Variables )
|
( Variables, UIElements )
|
||||||
import MetaBrush.Document
|
import MetaBrush.Document
|
||||||
( Document )
|
( Document )
|
||||||
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
import {-# SOURCE #-} MetaBrush.UI.InfoBar
|
||||||
|
@ -28,14 +28,11 @@ data TabLocation
|
||||||
= AfterCurrentTab
|
= AfterCurrentTab
|
||||||
| LastTab
|
| LastTab
|
||||||
|
|
||||||
|
instance Show TabLocation
|
||||||
|
|
||||||
createFileBar
|
createFileBar
|
||||||
:: Variables
|
:: Variables
|
||||||
-> GTK.Window -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
-> GTK.Window -> GTK.Box -> GTK.Label -> GTK.DrawingArea -> InfoBar
|
||||||
-> IO FileBar
|
-> IO FileBar
|
||||||
|
|
||||||
newFileTab
|
newFileTab :: Variables -> UIElements -> Maybe Document -> TabLocation -> IO ()
|
||||||
:: Variables
|
|
||||||
-> GTK.Window -> GTK.Label -> FileBar -> GTK.DrawingArea -> InfoBar
|
|
||||||
-> Maybe Document
|
|
||||||
-> TabLocation
|
|
||||||
-> IO ()
|
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
{-# LANGUAGE BlockArguments #-}
|
{-# LANGUAGE BlockArguments #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE DerivingStrategies #-}
|
{-# LANGUAGE DerivingStrategies #-}
|
||||||
|
@ -10,6 +11,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
@ -59,17 +61,18 @@ import Control.Monad.IO.Class
|
||||||
|
|
||||||
-- MetaBrush
|
-- MetaBrush
|
||||||
import MetaBrush.Action
|
import MetaBrush.Action
|
||||||
( quitEverything )
|
|
||||||
import MetaBrush.Context
|
import MetaBrush.Context
|
||||||
( LR(..), Modifier(..), modifierType )
|
( UIElements(..), Variables(..)
|
||||||
|
, LR(..), Modifier(..), modifierType
|
||||||
|
)
|
||||||
import MetaBrush.Asset.Colours
|
import MetaBrush.Asset.Colours
|
||||||
( Colours )
|
( Colours )
|
||||||
import MetaBrush.Asset.WindowIcons
|
import MetaBrush.Asset.WindowIcons
|
||||||
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
|
||||||
|
import MetaBrush.UI.FileBar
|
||||||
|
( TabLocation(..) )
|
||||||
import MetaBrush.Util
|
import MetaBrush.Util
|
||||||
( widgetAddClass, widgetAddClasses
|
( widgetAddClass, widgetAddClasses )
|
||||||
, (>>?=)
|
|
||||||
)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Types for describing menu items.
|
-- Types for describing menu items.
|
||||||
|
@ -78,16 +81,16 @@ data ResourceType
|
||||||
= Description
|
= Description
|
||||||
| Object
|
| Object
|
||||||
|
|
||||||
data family MenuItem ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
|
data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType )
|
||||||
data instance MenuItem submenu Description
|
data instance MenuItem action submenu Description
|
||||||
= MenuItemDescription
|
= MenuItemDescription
|
||||||
{ menuItemLabel :: !Text
|
{ menuItemLabel :: !Text
|
||||||
, menuItemClasses :: ![ Text ]
|
, menuItemClasses :: ![ Text ]
|
||||||
, menuItemAction :: !( Maybe Text )
|
, menuItemAction :: !action
|
||||||
, menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) )
|
, menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) )
|
||||||
, submenuDescription :: !( submenu Description )
|
, submenuDescription :: !( submenu Description )
|
||||||
}
|
}
|
||||||
data instance MenuItem submenu Object
|
data instance MenuItem action submenu Object
|
||||||
= MenuItem
|
= MenuItem
|
||||||
{ menuItem :: !GTK.MenuItem
|
{ menuItem :: !GTK.MenuItem
|
||||||
, menuItemSubmenu :: !( submenu Object )
|
, menuItemSubmenu :: !( submenu Object )
|
||||||
|
@ -110,41 +113,55 @@ data NoSubresource ( k :: ResourceType ) = NoSubresource
|
||||||
|
|
||||||
data Menu ( rt :: ResourceType )
|
data Menu ( rt :: ResourceType )
|
||||||
= Menu
|
= Menu
|
||||||
{ file :: !( MenuItem FileMenu rt )
|
{ file :: !( MenuItem () FileMenu rt )
|
||||||
, edit :: !( MenuItem EditMenu rt )
|
, edit :: !( MenuItem () EditMenu rt )
|
||||||
, view :: !( MenuItem ViewMenu rt )
|
, view :: !( MenuItem () ViewMenu rt )
|
||||||
, help :: !( MenuItem HelpMenu rt )
|
, help :: !( MenuItem () HelpMenu rt )
|
||||||
}
|
}
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
|
|
||||||
data FileMenu ( rt :: ResourceType )
|
data FileMenu ( rt :: ResourceType )
|
||||||
= FileMenu
|
= 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
|
deriving stock Generic
|
||||||
|
|
||||||
data EditMenu ( rt :: ResourceType )
|
data EditMenu ( rt :: ResourceType )
|
||||||
= EditMenu
|
= EditMenu
|
||||||
{ undo, redo, history :: !( MenuItem NoSubresource rt )
|
{ undo :: !( MenuItem Undo NoSubresource rt )
|
||||||
, editSep1 :: !( Separator rt )
|
, redo :: !( MenuItem Redo NoSubresource rt )
|
||||||
, cut, copy, paste, duplicate, delete :: !( MenuItem NoSubresource rt )
|
, editSep1 :: !( Separator rt )
|
||||||
, editSep2 :: !( Separator rt )
|
, cut :: !( MenuItem Cut NoSubresource rt )
|
||||||
, preferences :: !( MenuItem 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
|
deriving stock Generic
|
||||||
|
|
||||||
data ViewMenu ( rt :: ResourceType )
|
data ViewMenu ( rt :: ResourceType )
|
||||||
= ViewMenu
|
= ViewMenu
|
||||||
{ navigator :: !( MenuItem NoSubresource rt )
|
{ navigator :: !( MenuItem () NoSubresource rt )
|
||||||
, viewSep1 :: !( Separator rt )
|
, history :: !( MenuItem () NoSubresource rt )
|
||||||
, strokes, brushes, metaparameters :: !( MenuItem NoSubresource rt )
|
, viewSep1 :: !( Separator rt )
|
||||||
, viewSep2 :: !( Separator rt )
|
, strokes :: !( MenuItem () NoSubresource rt )
|
||||||
, transform :: !( MenuItem NoSubresource rt )
|
, brushes :: !( MenuItem () NoSubresource rt )
|
||||||
|
, metaparameters :: !( MenuItem () NoSubresource rt )
|
||||||
|
, viewSep2 :: !( Separator rt )
|
||||||
|
, transform :: !( MenuItem () NoSubresource rt )
|
||||||
}
|
}
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
|
|
||||||
data HelpMenu ( rt :: ResourceType )
|
data HelpMenu ( rt :: ResourceType )
|
||||||
= HelpMenu
|
= HelpMenu
|
||||||
{ about :: !( MenuItem NoSubresource rt ) }
|
{ about :: !( MenuItem About NoSubresource rt ) }
|
||||||
deriving stock Generic
|
deriving stock Generic
|
||||||
|
|
||||||
-- Descriptions.
|
-- Descriptions.
|
||||||
|
@ -152,93 +169,103 @@ data HelpMenu ( rt :: ResourceType )
|
||||||
menuDescription :: Menu Description
|
menuDescription :: Menu Description
|
||||||
menuDescription
|
menuDescription
|
||||||
= Menu
|
= Menu
|
||||||
{ file = MenuItemDescription "File" [ "menuItem", "file" ] Nothing Nothing fileMenuDescription
|
{ file = MenuItemDescription "File" [ "menuItem", "file" ] () Nothing fileMenuDescription
|
||||||
, edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] Nothing Nothing editMenuDescription
|
, edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] () Nothing editMenuDescription
|
||||||
, view = MenuItemDescription "View" [ "menuItem", "view" ] Nothing Nothing viewMenuDescription
|
, view = MenuItemDescription "View" [ "menuItem", "view" ] () Nothing viewMenuDescription
|
||||||
, help = MenuItemDescription "Help" [ "menuItem", "help" ] Nothing Nothing helpMenuDescription
|
, help = MenuItemDescription "Help" [ "menuItem", "help" ] () Nothing helpMenuDescription
|
||||||
}
|
}
|
||||||
|
|
||||||
fileMenuDescription :: FileMenu Description
|
fileMenuDescription :: FileMenu Description
|
||||||
fileMenuDescription
|
fileMenuDescription
|
||||||
= FileMenu
|
= FileMenu
|
||||||
{ new = MenuItemDescription "New" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
|
{ new = MenuItemDescription "New" [ "submenuItem" ] ( NewFile AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource
|
||||||
, open = MenuItemDescription "Open" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
|
, open = MenuItemDescription "Open" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource
|
||||||
, save = MenuItemDescription "Save" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
|
, save = MenuItemDescription "Save" [ "submenuItem" ] Save ( Just ( GDK.KEY_S, [ Control L ] ) ) NoSubresource
|
||||||
, saveAs = MenuItemDescription "Save as" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
|
, saveAs = MenuItemDescription "Save as" [ "submenuItem" ] SaveAs ( Just ( GDK.KEY_S, [ Control L, Shift L ] ) ) NoSubresource
|
||||||
, close = MenuItemDescription "Close" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
|
, close = MenuItemDescription "Close" [ "submenuItem" ] Close ( Just ( GDK.KEY_W, [ Control L ] ) ) NoSubresource
|
||||||
, quit = MenuItemDescription "Quit" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
|
, quit = MenuItemDescription "Quit" [ "submenuItem" ] Quit ( Just ( GDK.KEY_Q, [ Control L ] ) ) NoSubresource
|
||||||
}
|
}
|
||||||
|
|
||||||
editMenuDescription :: EditMenu Description
|
editMenuDescription :: EditMenu Description
|
||||||
editMenuDescription
|
editMenuDescription
|
||||||
= EditMenu
|
= EditMenu
|
||||||
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
|
{ undo = MenuItemDescription "Undo" [ "submenuItem" ] Undo ( Just ( GDK.KEY_Z, [ Control L ] ) ) NoSubresource
|
||||||
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
|
, redo = MenuItemDescription "Redo" [ "submenuItem" ] Redo ( Just ( GDK.KEY_Y, [ Control L ] ) ) NoSubresource
|
||||||
, history = MenuItemDescription "History" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_H, [ Control L ] ) ) NoSubresource
|
|
||||||
, editSep1 = SeparatorDescription [ "submenuSeparator" ]
|
, editSep1 = SeparatorDescription [ "submenuSeparator" ]
|
||||||
, cut = MenuItemDescription "Cut" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
|
, cut = MenuItemDescription "Cut" [ "submenuItem" ] Cut ( Just ( GDK.KEY_X, [ Control L ] ) ) NoSubresource
|
||||||
, copy = MenuItemDescription "Copy" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
|
, copy = MenuItemDescription "Copy" [ "submenuItem" ] Copy ( Just ( GDK.KEY_C, [ Control L ] ) ) NoSubresource
|
||||||
, paste = MenuItemDescription "Paste" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
|
, paste = MenuItemDescription "Paste" [ "submenuItem" ] Paste ( Just ( GDK.KEY_V, [ Control L ] ) ) NoSubresource
|
||||||
, duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
|
, duplicate = MenuItemDescription "Duplicate" [ "submenuItem" ] Duplicate ( Just ( GDK.KEY_D, [ Control L ] ) ) NoSubresource
|
||||||
, delete = MenuItemDescription "Delete" [ "submenuItem" ] Nothing ( Just ( GDK.KEY_Delete, [] ) ) NoSubresource
|
, delete = MenuItemDescription "Delete" [ "submenuItem" ] Delete ( Just ( GDK.KEY_Delete, [] ) ) NoSubresource
|
||||||
, editSep2 = SeparatorDescription [ "submenuSeparator" ]
|
, 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 Description
|
||||||
viewMenuDescription
|
viewMenuDescription
|
||||||
= ViewMenu
|
= 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" ]
|
, viewSep1 = SeparatorDescription [ "submenuSeparator" ]
|
||||||
, strokes = MenuItemDescription "Strokes" [ "submenuItem" ] Nothing Nothing NoSubresource
|
, strokes = MenuItemDescription "Strokes" [ "submenuItem" ] () Nothing NoSubresource
|
||||||
, brushes = MenuItemDescription "Brushes" [ "submenuItem" ] Nothing Nothing NoSubresource
|
, brushes = MenuItemDescription "Brushes" [ "submenuItem" ] () Nothing NoSubresource
|
||||||
, metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] Nothing Nothing NoSubresource
|
, metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] () Nothing NoSubresource
|
||||||
, viewSep2 = SeparatorDescription [ "submenuSeparator" ]
|
, viewSep2 = SeparatorDescription [ "submenuSeparator" ]
|
||||||
, transform = MenuItemDescription "Transform" [ "submenuItem" ] Nothing Nothing NoSubresource
|
, transform = MenuItemDescription "Transform" [ "submenuItem" ] () Nothing NoSubresource
|
||||||
}
|
}
|
||||||
|
|
||||||
helpMenuDescription :: HelpMenu Description
|
helpMenuDescription :: HelpMenu Description
|
||||||
helpMenuDescription
|
helpMenuDescription
|
||||||
= HelpMenu
|
= 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.
|
-- Creating a GTK menu bar from a menu description.
|
||||||
|
|
||||||
newMenuItem :: MonadIO m => MenuItem submenu Description -> m GTK.MenuItem
|
newMenuItem
|
||||||
newMenuItem ( MenuItemDescription { .. } ) = do
|
:: ( 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
|
menuItem <- GTK.menuItemNewWithLabel menuItemLabel
|
||||||
for_ menuItemAccel \ ( key, modifiers ) -> do
|
for_ menuItemAccel \ ( key, modifiers ) -> do
|
||||||
mbAccelLabel <- liftIO ( GTK.binGetChild menuItem >>?= ( GTK.castTo GTK.AccelLabel ) )
|
GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ]
|
||||||
for_ mbAccelLabel \ accelLabel -> do
|
GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel"
|
||||||
GTK.accelLabelSetAccel accelLabel key ( map modifierType modifiers )
|
|
||||||
widgetAddClass accelLabel "accelLabel"
|
|
||||||
unless ( null menuItemClasses ) do
|
unless ( null menuItemClasses ) do
|
||||||
widgetAddClasses menuItem menuItemClasses
|
widgetAddClasses menuItem menuItemClasses
|
||||||
for_ menuItemAction \ actionName -> do
|
void $ GTK.onMenuItemActivate menuItem
|
||||||
GTK.actionableSetActionName menuItem ( Just actionName )
|
( handleAction uiElts vars menuItemAction )
|
||||||
pure menuItem
|
pure menuItem
|
||||||
|
|
||||||
class CreateMenuItem desc res | desc -> res, res -> desc where
|
class CreateMenuItem desc res | desc -> res, res -> desc where
|
||||||
createMenuItem :: MonadIO m => ( GTK.MenuItem -> m () ) -> desc -> m res
|
createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res
|
||||||
instance {-# OVERLAPPING #-} CreateMenuItem ( MenuItem NoSubresource Description ) ( MenuItem NoSubresource Object ) where
|
instance {-# OVERLAPPING #-}
|
||||||
createMenuItem attachToParent menuItemDescription = do
|
HandleAction action
|
||||||
menuItem <- newMenuItem menuItemDescription
|
=> 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
|
attachToParent menuItem
|
||||||
pure
|
pure
|
||||||
MenuItem
|
MenuItem
|
||||||
{ menuItem = menuItem
|
{ menuItem = menuItem
|
||||||
, menuItemSubmenu = NoSubresource
|
, menuItemSubmenu = NoSubresource
|
||||||
}
|
}
|
||||||
instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
|
instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) )
|
||||||
=> CreateMenuItem ( MenuItem submenu Description ) ( MenuItem submenu Object )
|
=> CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object )
|
||||||
where
|
where
|
||||||
createMenuItem attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
|
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do
|
||||||
menuItem <- newMenuItem menuItemDescription
|
menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription
|
||||||
submenu <- GTK.menuNew
|
submenu <- GTK.menuNew
|
||||||
|
GTK.menuSetAccelGroup submenu ( Just accelGroup )
|
||||||
submenuItems <-
|
submenuItems <-
|
||||||
constraints @CreateMenuItem
|
constraints @CreateMenuItem
|
||||||
( createMenuItem ( GTK.menuShellAppend submenu ) )
|
( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend submenu ) )
|
||||||
submenuDescription
|
submenuDescription
|
||||||
GTK.menuItemSetSubmenu menuItem ( Just submenu )
|
GTK.menuItemSetSubmenu menuItem ( Just submenu )
|
||||||
attachToParent menuItem
|
attachToParent menuItem
|
||||||
|
@ -248,7 +275,7 @@ instance ( HasConstraints CreateMenuItem ( submenu Description ) ( submenu Objec
|
||||||
, menuItemSubmenu = submenuItems
|
, menuItemSubmenu = submenuItems
|
||||||
}
|
}
|
||||||
instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
|
instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
|
||||||
createMenuItem attachToParent ( SeparatorDescription { .. } ) = do
|
createMenuItem _ _ _ attachToParent ( SeparatorDescription { .. } ) = do
|
||||||
separator <- GTK.separatorMenuItemNew
|
separator <- GTK.separatorMenuItemNew
|
||||||
unless ( null separatorClasses ) do
|
unless ( null separatorClasses ) do
|
||||||
widgetAddClasses separator separatorClasses
|
widgetAddClasses separator separatorClasses
|
||||||
|
@ -256,12 +283,12 @@ instance CreateMenuItem ( Separator Description ) ( Separator Object ) where
|
||||||
attachToParent sep
|
attachToParent sep
|
||||||
pure ( Separator { separatorItem = sep } )
|
pure ( Separator { separatorItem = sep } )
|
||||||
|
|
||||||
newMenuBar :: MonadIO m => m ( GTK.MenuBar, Menu Object )
|
newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object )
|
||||||
newMenuBar = do
|
newMenuBar uiElts vars accelGroup = do
|
||||||
menuBar <- GTK.menuBarNew
|
menuBar <- GTK.menuBarNew
|
||||||
menu <-
|
menu <-
|
||||||
constraints @CreateMenuItem
|
constraints @CreateMenuItem
|
||||||
( createMenuItem ( GTK.menuShellAppend menuBar ) )
|
( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend menuBar ) )
|
||||||
menuDescription
|
menuDescription
|
||||||
pure ( menuBar, menu )
|
pure ( menuBar, menu )
|
||||||
|
|
||||||
|
@ -269,9 +296,11 @@ newMenuBar = do
|
||||||
-- Creating the menu bar from its declarative specification.
|
-- Creating the menu bar from its declarative specification.
|
||||||
|
|
||||||
-- | Add the menu bar to the given box (title bar box).
|
-- | Add the menu bar to the given box (title bar box).
|
||||||
createMenuBar :: Colours -> GTK.Window -> GTK.Box -> IO ( Menu Object )
|
createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object )
|
||||||
createMenuBar colours window titleBar = do
|
createMenuBar uiElts@( UIElements { titleBar, window } ) vars colours = do
|
||||||
( menuBar, menu ) <- newMenuBar
|
accelGroup <- GTK.accelGroupNew
|
||||||
|
GTK.windowAddAccelGroup window accelGroup
|
||||||
|
( menuBar, menu ) <- newMenuBar uiElts vars accelGroup
|
||||||
widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
|
widgetAddClasses menuBar [ "menuBar", "text", "plain" ]
|
||||||
GTK.boxPackStart titleBar menuBar False False 0
|
GTK.boxPackStart titleBar menuBar False False 0
|
||||||
|
|
||||||
|
|
|
@ -101,7 +101,7 @@ fitSpline maxSubdiv nbSegments dist_tol t_tol maxIters = go 0
|
||||||
qs :: [ Point2D Double ]
|
qs :: [ Point2D Double ]
|
||||||
(p, tp) = curve 0
|
(p, tp) = curve 0
|
||||||
(r, tr) = curve 1
|
(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
|
in
|
||||||
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
|
case fitPiece dist_tol t_tol maxIters p tp qs r tr of
|
||||||
( bez, Max ( Arg t_split sq_d ) )
|
( bez, Max ( Arg t_split sq_d ) )
|
||||||
|
|
Loading…
Reference in a new issue