From db4115c6343ba56e6059b4d570f6c551cf1cafe5 Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 2 Sep 2020 22:49:50 +0200 Subject: [PATCH] hook up menu to actions, + some refactors --- MetaBrush.cabal | 2 - app/Main.hs | 34 +-- src/app/MetaBrush/Action.hs | 290 +++++++++++++++++------- src/app/MetaBrush/Context.hs | 1 + src/app/MetaBrush/Document/Selection.hs | 1 - src/app/MetaBrush/Event.hs | 68 +++--- src/app/MetaBrush/UI/FileBar.hs | 25 +- src/app/MetaBrush/UI/FileBar.hs-boot | 13 +- src/app/MetaBrush/UI/Menu.hs | 177 +++++++++------ src/lib/Math/Bezier/Cubic/Fit.hs | 2 +- 10 files changed, 373 insertions(+), 240 deletions(-) diff --git a/MetaBrush.cabal b/MetaBrush.cabal index 9f23395..fe3c007 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -150,8 +150,6 @@ executable MetaBrush ^>= 0.0.1 , haskell-gi-base ^>= 0.24 - , haskus-utils-variant - ^>= 3.0 , lens ^>= 4.19.2 , scientific diff --git a/app/Main.hs b/app/Main.hs index 9980563..ea1dbc0 100644 --- a/app/Main.hs +++ b/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 diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index 98000d0..6f7c1cf 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -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 () ---------------------- diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 1659785..bd938ee 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -60,6 +60,7 @@ data UIElements = UIElements { window :: !GTK.Window , title :: !GTK.Label + , titleBar :: !GTK.Box , fileBar :: !FileBar , viewportDrawingArea :: !GTK.DrawingArea , infoBar :: !InfoBar diff --git a/src/app/MetaBrush/Document/Selection.hs b/src/app/MetaBrush/Document/Selection.hs index de46a0d..481c3fe 100644 --- a/src/app/MetaBrush/Document/Selection.hs +++ b/src/app/MetaBrush/Document/Selection.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 3b0efad..0c1891d 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -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 diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index b674e55..bccf926 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -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 diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index d71bb2a..9a2ac8b 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -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 () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index 45beb70..ae576c3 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -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 diff --git a/src/lib/Math/Bezier/Cubic/Fit.hs b/src/lib/Math/Bezier/Cubic/Fit.hs index 9f149fd..08bec6f 100644 --- a/src/lib/Math/Bezier/Cubic/Fit.hs +++ b/src/lib/Math/Bezier/Cubic/Fit.hs @@ -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 ) )