From 1b0382f3b040dfdf4cb7505c20a452c600b8a95b Mon Sep 17 00:00:00 2001 From: sheaf Date: Wed, 21 Apr 2021 15:08:33 +0000 Subject: [PATCH] Switch to GTK4 --- MetaBrush.cabal | 13 +- app/Main.hs | 466 +---------------------- assets/theme.css | 95 +++-- cabal.project | 12 - src/app/MetaBrush/Action.hs | 314 +++++++++------- src/app/MetaBrush/Action.hs-boot | 33 +- src/app/MetaBrush/Application.hs | 498 ++++++++++++++++++++++++ src/app/MetaBrush/Asset/Colours.hs | 94 +++-- src/app/MetaBrush/Context.hs | 85 ++--- src/app/MetaBrush/Document/Update.hs | 69 ++-- src/app/MetaBrush/Event.hs | 118 +++--- src/app/MetaBrush/UI/FileBar.hs | 201 +++++----- src/app/MetaBrush/UI/FileBar.hs-boot | 39 +- src/app/MetaBrush/UI/InfoBar.hs | 38 +- src/app/MetaBrush/UI/InfoBar.hs-boot | 7 +- src/app/MetaBrush/UI/Menu.hs | 542 ++++++++++++--------------- src/app/MetaBrush/UI/Menu.hs-boot | 53 --- src/app/MetaBrush/UI/Panels.hs | 15 +- src/app/MetaBrush/UI/ToolBar.hs | 128 ++++--- src/app/MetaBrush/UI/ToolBar.hs-boot | 4 +- src/app/MetaBrush/UI/Viewport.hs | 79 +++- src/app/MetaBrush/Util.hs | 8 +- 22 files changed, 1500 insertions(+), 1411 deletions(-) create mode 100644 src/app/MetaBrush/Application.hs delete mode 100644 src/app/MetaBrush/UI/Menu.hs-boot diff --git a/MetaBrush.cabal b/MetaBrush.cabal index c268b4f..10fb42d 100644 --- a/MetaBrush.cabal +++ b/MetaBrush.cabal @@ -10,7 +10,7 @@ data-dir: assets data-files: theme.css - icon.png + icons/* description: MetaBrush is a GUI for brush calligraphy based on Bézier curves. @@ -118,6 +118,7 @@ executable MetaBrush other-modules: MetaBrush.Action + , MetaBrush.Application , MetaBrush.Asset.Brushes , MetaBrush.Asset.CloseTabButton , MetaBrush.Asset.Colours @@ -175,7 +176,7 @@ executable MetaBrush , atomic-file-ops ^>= 0.3.0.0 , bytestring - ^>= 0.10.10.0 + >= 0.10.10.0 && < 0.12 , directory >= 1.3.4.0 && < 1.4 , dlist @@ -191,7 +192,7 @@ executable MetaBrush , gi-cairo-connector ^>= 0.1.0 , gi-gdk - >= 3.0.22 && < 3.1 + >= 4.0.2 && < 4.1 , gi-gio >= 2.0.27 && < 2.1 , gi-glib @@ -199,9 +200,9 @@ executable MetaBrush , gi-gobject ^>= 2.0.24 , gi-gtk - >= 3.0.35 && < 3.1 - , gi-gtksource - >= 3.0.23 && < 3.1 + >= 4.0.3 && < 4.1 + --, gi-gtksource + -- >= 3.0.23 && < 3.1 , hashable ^>= 1.3.0.0 , haskell-gi diff --git a/app/Main.hs b/app/Main.hs index 3933fb6..9c77d7a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,15 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} module Main ( main ) @@ -17,149 +7,24 @@ module Main -- base import Control.Monad - ( forever, void ) -import Control.Monad.ST - ( stToIO ) -import Data.Foldable - ( for_ ) -import Data.Function - ( (&) ) -import Data.Int - ( Int32 ) + ( void ) import System.Exit - ( exitSuccess ) + ( ExitCode(..), exitSuccess, exitWith ) import GHC.Conc - ( forkIO, getNumProcessors, setNumCapabilities ) + ( getNumProcessors, setNumCapabilities ) --- containers -import Data.Map.Strict - ( Map ) -import qualified Data.Map.Strict as Map - ( empty ) -import qualified Data.Sequence as Seq - ( fromList ) -import Data.Set - ( Set ) -import qualified Data.Set as Set - ( empty ) +-- gi-gio +import qualified GI.Gio as GIO --- directory -import qualified System.Directory as Directory - ( canonicalizePath ) - --- generic-lens -import Data.Generics.Product.Fields - ( field' ) - --- gi-cairo-render -import qualified GI.Cairo.Render as Cairo - ( Render ) - --- gi-cairo-connector -import qualified GI.Cairo.Render.Connector as Cairo - ( renderWithContext ) - --- gi-gdk -import qualified GI.Gdk as GDK - --- gi-glib -import qualified GI.GLib.Constants as GLib +-- gi-gobject +import qualified GI.GObject as GObject -- gi-gtk import qualified GI.Gtk as GTK --- lens -import Control.Lens - ( (.~) ) -import Control.Lens.At - ( at ) - --- stm -import qualified Control.Concurrent.STM as STM - ( atomically, retry ) -import qualified Control.Concurrent.STM.TVar as STM - ( newTVarIO, readTVar, writeTVar ) - --- superrecord -import qualified SuperRecord as Super - ( Rec ) -import qualified SuperRecord - ( (:=)(..), (&), rnil ) - --- text -import qualified Data.Text as Text - ( pack ) - --- transformers -import Control.Monad.Trans.Reader - ( runReaderT ) - --- unordered-containers -import Data.HashMap.Strict - ( HashMap ) -import qualified Data.HashMap.Strict as HashMap - ( fromList ) - -- MetaBrush -import Math.Bezier.Cubic.Fit - ( FitParameters(..) ) -import Math.Bezier.Spline - ( Spline(..), Curves(..), Curve(..), NextPoint(..) ) -import Math.Bezier.Stroke - ( invalidateCache ) -import Math.Vector2D - ( Point2D(..) ) -import MetaBrush.Action - ( ActionOrigin(..) ) -import qualified MetaBrush.Asset.Brushes as Asset.Brushes - ( circle ) -import MetaBrush.Asset.Colours - ( getColours ) -import MetaBrush.Asset.Logo - ( drawLogo ) -import MetaBrush.Brush - ( Brush, newBrushReference ) -import MetaBrush.Context - ( UIElements(..), Variables(..) - , Modifier(..) - , HoldAction(..), PartialPath(..) - ) -import MetaBrush.Document - ( emptyDocument - , Stroke(..), FocusState(..) - , PointData(..) - ) -import MetaBrush.Document.History - ( DocumentHistory(..), newHistory ) -import MetaBrush.Document.Update - ( activeDocument, withActiveDocument ) -import MetaBrush.Event - ( handleEvents ) -import MetaBrush.Render.Document - ( blankRender, getDocumentRender ) -import MetaBrush.Render.Rulers - ( renderRuler ) -import MetaBrush.UI.FileBar - ( FileBar(..), createFileBar ) -import MetaBrush.UI.InfoBar - ( InfoBar(..), createInfoBar, updateInfoBar ) -import MetaBrush.UI.Menu - ( createMenuBar ) -import MetaBrush.UI.Panels - ( createPanelBar ) -import MetaBrush.UI.ToolBar - ( Tool(..), Mode(..), createToolBar ) -import MetaBrush.UI.Viewport - ( Viewport(..), Ruler(..), createViewport ) -import MetaBrush.Unique - ( newUniqueSupply - , Unique, freshUnique - , uniqueMapFromList - ) -import MetaBrush.Util - ( widgetAddClass, widgetAddClasses ) -import qualified Paths_MetaBrush as Cabal - ( getDataFileName ) +import MetaBrush.Application + ( runApplication ) -------------------------------------------------------------------------------- @@ -179,305 +44,14 @@ main = do setNumCapabilities caps --------------------------------------------------------- - -- Initialise state + -- Run GTK application - uniqueSupply <- newUniqueSupply + application <- GTK.applicationNew ( Just "com.calligraphy.MetaBrush" ) [ GIO.ApplicationFlagsNonUnique ] + GIO.applicationRegister application ( Nothing @GIO.Cancellable ) + void $ GIO.onApplicationActivate application ( runApplication application ) + exitCode <- GIO.applicationRun application Nothing + GObject.objectUnref application - circleBrush <- Asset.Brushes.circle uniqueSupply - circleBrushUnique <- runReaderT freshUnique uniqueSupply - docUnique <- runReaderT freshUnique uniqueSupply - strokeUnique <- runReaderT freshUnique uniqueSupply - - let - - testBrushes :: HashMap Brush Unique - testBrushes = HashMap.fromList - [ ( circleBrush, circleBrushUnique ) ] - - testDocuments :: Map Unique DocumentHistory - testDocuments = fmap newHistory $ uniqueMapFromList - [ emptyDocument "Test" docUnique - & ( field' @"documentContent" . field' @"strokes" ) .~ - [ Stroke - { strokeName = "Stroke 1" - , strokeVisible = True - , strokeUnique = strokeUnique - , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique - , strokeSpline = - Spline - { splineStart = mkPoint ( Point2D 10 -20 ) 2 - , splineCurves = OpenCurves $ Seq.fromList - [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined } - , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined } - , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined } - ] - } - } - ] - & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush ) - ] - where - mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] ) - mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil ) - - recomputeStrokesTVar <- STM.newTVarIO @Bool False - documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) - activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing - openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments - brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes - mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing - mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing - modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty - toolTVar <- STM.newTVarIO @Tool Selection - modeTVar <- STM.newTVarIO @Mode PathMode - debugTVar <- STM.newTVarIO @Bool False - partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing - fileBarTabsTVar <- STM.newTVarIO @( Map Unique ( GTK.Box, GTK.RadioButton ) ) Map.empty - showGuidesTVar <- STM.newTVarIO @Bool True - maxHistorySizeTVar <- STM.newTVarIO @Int 1000 - fitParametersTVar <- STM.newTVarIO @FitParameters - ( FitParameters - { maxSubdiv = 6 - , nbSegments = 12 - , dist_tol = 5e-3 - , t_tol = 1e-4 - , maxIters = 100 - } - ) - - -- Put all these stateful variables in a record for conciseness. - let - variables :: Variables - variables = Variables {..} - - --------------------------------------------------------- - -- Initialise GTK - - void $ GTK.init Nothing - Just screen <- GDK.screenGetDefault - - themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" ) - cssProvider <- GTK.cssProviderNew - GTK.cssProviderLoadFromPath cssProvider themePath - GTK.styleContextAddProviderForScreen screen cssProvider 1000 - - window <- GTK.windowNew GTK.WindowTypeToplevel - windowWidgetPath <- GTK.widgetGetPath window - widgetAddClass window "window" - GTK.setWindowResizable window True - GTK.setWindowDecorated window False - GTK.setWindowTitle window "MetaBrush" - GTK.windowSetDefaultSize window 1024 768 - GTK.widgetAddEvents window - [ GDK.EventMaskKeyPressMask, GDK.EventMaskKeyReleaseMask ] - - let - baseMinWidth, baseMinHeight :: Int32 - baseMinWidth = 480 - baseMinHeight = 240 - - windowGeometry <- GDK.newZeroGeometry - GDK.setGeometryMinWidth windowGeometry baseMinWidth - GDK.setGeometryMinHeight windowGeometry baseMinHeight - GTK.windowSetGeometryHints window ( Nothing @GTK.Widget ) - ( Just windowGeometry ) - [ GDK.WindowHintsMinSize ] - - iconPath <- Directory.canonicalizePath =<< Cabal.getDataFileName "icon.png" - GTK.windowSetIconFromFile window iconPath - - colours <- getColours windowWidgetPath - - --------------------------------------------------------- - -- Create base UI elements - - baseOverlay <- GTK.overlayNew - GTK.setContainerChild window baseOverlay - - uiGrid <- GTK.gridNew - GTK.setContainerChild baseOverlay uiGrid - - logo <- GTK.boxNew GTK.OrientationVertical 0 - titleBar <- GTK.boxNew GTK.OrientationHorizontal 0 - toolBar <- GTK.boxNew GTK.OrientationVertical 0 - mainPane <- GTK.panedNew GTK.OrientationHorizontal - panelBox <- GTK.boxNew GTK.OrientationVertical 0 - - GTK.gridAttach uiGrid logo 0 0 1 2 - GTK.gridAttach uiGrid titleBar 1 0 2 1 - GTK.gridAttach uiGrid toolBar 0 2 2 1 - GTK.gridAttach uiGrid mainPane 2 2 1 1 - - mainView <- GTK.boxNew GTK.OrientationVertical 0 - - GTK.panedPack1 mainPane mainView True False - GTK.panedPack2 mainPane panelBox False False - - viewportGrid <- GTK.gridNew - - --------------------------------------------------------- - -- Background - - widgetAddClass uiGrid "bg" - - --------------------------------------------------------- - -- Title bar - - widgetAddClass titleBar "titleBar" - - -------- - -- Logo - - widgetAddClass logo "logo" - - logoArea <- GTK.drawingAreaNew - GTK.boxPackStart logo logoArea True True 0 - - void $ GTK.onWidgetDraw logoArea - $ Cairo.renderWithContext ( drawLogo colours ) - - ------------ - -- Title - - title <- GTK.labelNew ( Just "MetaBrush" ) - widgetAddClasses title [ "text", "title", "plain" ] - GTK.boxSetCenterWidget titleBar ( Just title ) - - --------------------------------------------------------- - -- Main viewport - - viewport@( Viewport {..} ) <- createViewport viewportGrid - - ----------------- - -- Viewport rendering - - -- Update the document render data in a separate thread. - _ <- forkIO $ forever do - getRenderDoc <- STM.atomically do - needsRecomputation <- STM.readTVar recomputeStrokesTVar - case needsRecomputation of - False -> STM.retry - True -> do - mbDocNow <- fmap present <$> activeDocument variables - case mbDocNow of - Nothing -> pure ( pure . const $ blankRender colours ) - Just doc -> do - modifiers <- STM.readTVar modifiersTVar - mbMousePos <- STM.readTVar mousePosTVar - mbHoldAction <- STM.readTVar mouseHoldTVar - mbPartialPath <- STM.readTVar partialPathTVar - mode <- STM.readTVar modeTVar - showGuides <- STM.readTVar showGuidesTVar - debug <- STM.readTVar debugTVar - fitParameters <- STM.readTVar fitParametersTVar - STM.writeTVar recomputeStrokesTVar False - let - addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) - addRulers newRender viewportSize = do - newRender viewportSize - renderRuler - colours viewportSize ViewportOrigin viewportSize - mbMousePos mbHoldAction showGuides - doc - pure - ( addRulers <$> getDocumentRender - colours fitParameters mode debug - modifiers mbMousePos mbHoldAction mbPartialPath - doc - ) - renderDoc <- stToIO getRenderDoc - STM.atomically do - STM.writeTVar documentRenderTVar renderDoc - void do - GDK.threadsAddIdle GLib.PRIORITY_HIGH_IDLE - ( False <$ GTK.widgetQueueDraw viewportDrawingArea ) - - -- Render the document using the latest available draw data. - void $ GTK.onWidgetDraw viewportDrawingArea \ ctx -> do - viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - -- Get the Cairo instructions for rendering the current document - mbDoc <- fmap present <$> STM.atomically ( activeDocument variables ) - render <- case mbDoc of - Nothing -> pure ( blankRender colours ) - Just _ -> STM.atomically do - render <- STM.readTVar documentRenderTVar - pure ( render ( viewportWidth, viewportHeight ) ) - Cairo.renderWithContext render ctx - pure True - - for_ [ ( rulerCornerDrawingArea , RulerCorner ) - , ( topRulerDrawingArea , TopRuler ) - , ( leftRulerDrawingArea , LeftRuler ) - ] \ ( rulerDrawingArea, ruler ) -> do - void $ GTK.onWidgetDraw rulerDrawingArea \ ctx -> do - viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea - width <- GTK.widgetGetAllocatedWidth rulerDrawingArea - height <- GTK.widgetGetAllocatedHeight rulerDrawingArea - mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do - mbMousePos <- STM.readTVar mousePosTVar - mbHoldAction <- STM.readTVar mouseHoldTVar - showGuides <- STM.readTVar showGuidesTVar - pure do - renderRuler - colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height ) - mbMousePos mbHoldAction showGuides - doc - for_ mbRender \ render -> Cairo.renderWithContext render ctx - - pure True - - --------------------------------------------------------- - -- Tool bar - - _ <- createToolBar variables colours toolBar - - --------------------------------------------------------- - -- Info bar - - infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours - - rec - - --------------------------------------------------------- - -- File bar - - fileBar@( FileBar { fileBarBox } ) <- - createFileBar - colours - variables - window titleBar title viewport infoBar menu - - ------------ - -- Menu bar - - let - uiElements :: UIElements - uiElements = UIElements { menu, fileBar, .. } - - menu <- createMenuBar uiElements variables colours - - GTK.boxPackStart mainView fileBarBox False False 0 - GTK.boxPackStart mainView viewportGrid True True 0 - GTK.boxPackStart mainView infoBarArea False False 0 - - --------------------------------------------------------- - -- Panels - - createPanelBar panelBox - - --------------------------------------------------------- - -- Actions - - handleEvents uiElements variables - - --------------------------------------------------------- - -- GTK main loop - - GTK.widgetShowAll window - mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables ) - updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized - GTK.main - - exitSuccess + case exitCode of + 0 -> exitSuccess + _ -> exitWith ( ExitFailure $ fromIntegral exitCode ) diff --git a/assets/theme.css b/assets/theme.css index 4bb24ec..7b817da 100644 --- a/assets/theme.css +++ b/assets/theme.css @@ -1,13 +1,17 @@ -* { + +.metabrush * { all: unset; } + /* Colors parsed by application */ .bg { background-color: rgb(41, 40, 40); + color: rgb(41, 40, 40); } .active { background-color: rgb(72,70,61); + color: rgb(72,70,61); } .close { color: rgb(181,43,43); @@ -65,21 +69,24 @@ } .viewport { background-color: rgb(236, 223, 210); - -GtkWidget-window-dragging: false; + color: rgb(236, 223, 210); min-width: 120px; min-height: 90px; } .viewportScrollbar { background-color: rgba(45, 39, 39, 0.66); + color: rgba(45, 39, 39, 0.66); margin: 4px; min-width: 8px; min-height: 8px; } .tabScrollbar { background-color: rgba(48, 45, 38, 0.66); + color: rgba(48, 45, 38, 0.66); } .ruler { background-color: rgb(237, 226, 154); + color: rgb(237, 226, 154); min-width: 16px; min-height: 16px; background-size: 16px 16px; @@ -97,7 +104,7 @@ color: rgba(156, 231, 255, 0.5); } .selected { - color: rgba(161,201,236,0.5) + color: rgba(161,201,236,0.5); } .selectedOutline { color: rgb(74,150,218); @@ -113,10 +120,17 @@ tooltip { border: 1px solid rgb(28,25,25); } + .window, .dialog { - -GtkWidget-window-dragging: true; + border-radius: 0px; + border-color: rgb(28,25,25); + box-shadow: + 0px 3px 9px 1px rgba(0,0,0,0), + 0px 2px 6px 2px rgba(0,0,0,0.2), + 0px 0px 0px 1px rgba(0,0,0,0.18); } + /* Basic text colour */ /* Basic text font */ @@ -193,6 +207,7 @@ tooltip { .titleBar { min-height: 24px; font-size: 12px; + background-color: rgb(41, 40, 40); } /* @@ -228,66 +243,65 @@ tooltip { background-color: #eadfcc; } +/* Menu bar */ -.menuBar { - padding-left: 4px; +.menu label { + color:rgb(212, 190, 152); } -.menuItem { - color: rgba(212, 190, 152,0.5); - background-color: rgb(41, 40, 40); +.menu :disabled { + color:rgb(149,149,149); +} + +.menu item { padding-left: 8px; padding-right: 8px; - margin-left: 0px; + color: rgb(212, 190, 152); border-top: 2px solid rgb(41, 40, 40); } -/* Menu item hover effect (workaround) */ -.menuItem:selected { +.menu :hover { + color: rgb(212, 190, 152); border-color: rgb(72,70,61); - color: rgb(212, 190, 152); } -/* Styling for active menu item */ -.menuItem:active, .menuItem:checked, .menuItem:hover { - border-color: rgb(234,223,204); +.menu item > * :hover { + border-color: rgb(212, 190, 152); background-color: rgb(72,70,61); - color: rgb(212, 190, 152); } -.menuItem > * > * { - box-shadow: 2px 4px 3px -1px rgba(28,25,25,0.5); - border: 1px solid rgb(28,25,25); - border-top: 1px solid rgb(72,70,61); - color: rgb(212, 190, 152); +/* Top-level menu items */ + +/* TODO: shadows not working properly */ +.menu item > popover > contents > stack > box > box { + box-shadow: 0 0 1px 2px rgba(0,0,0,0.5); } -.submenuItem { - color: rgb(212, 190, 152); - padding-top: 4px; - padding-bottom: 4px; - padding-left: 10px; - padding-right: 10px; +/* Submenus without separators */ +.menu item > popover > contents > stack > box > box > modelbutton { background-color: rgb(41, 40, 40); + color: rgb(72,70,61); + border-top: 0px; border-left: 2px solid rgb(41, 40, 40); + padding: 2px 10px 6px 10px; } -.submenuItem:hover{ +/* Submenus with separators */ +.menu item > popover > contents > stack > box > box > box > box > modelbutton { + background-color: rgb(41, 40, 40); + color: rgb(72,70,61); + border-top: 0px; + border-left: 2px solid rgb(41, 40, 40); + padding: 2px 10px 6px 10px; +} + +.menu item > popover > contents > stack > box > box > box > separator, +.menu item > popover > contents > stack > box > box > box > separator :hover { background-color: rgb(72,70,61); + padding: 1px 0px 0px 1px; } -.submenuItem:disabled { - color: rgb(149,149,149); -} -.submenuSeparator { - background-color: rgb(28,25,25); - padding-top: 1px; -} - -.submenuItem:hover { - border-color: rgb(234,223,204); -} .accelLabel { padding: 2px 8px 2px 0px; @@ -441,7 +455,6 @@ tooltip { .infoBar { min-height: 40px; font-size: 10px; - -GtkWidget-window-dragging: true; } .infoBarInfo { diff --git a/cabal.project b/cabal.project index cdc3908..04fa13a 100644 --- a/cabal.project +++ b/cabal.project @@ -30,18 +30,6 @@ source-repository-package location: https://github.com/sheaf/generic-lens tag: 8d3f0b405894ecade5821c99dcde6efb4a637363 --- GHC 9.0 compatibility for 'haskell-gi' and 'haskell-gi-base' -source-repository-package - type: git - location: https://github.com/haskell-gi/haskell-gi - tag: cc6c25a32288ceef79585e8bba5f197065fb477c - subdir: . -source-repository-package - type: git - location: https://github.com/haskell-gi/haskell-gi - tag: cc6c25a32288ceef79585e8bba5f197065fb477c - subdir: base - -- superrecord API improvements source-repository-package type: git diff --git a/src/app/MetaBrush/Action.hs b/src/app/MetaBrush/Action.hs index be911c2..6a3cd8c 100644 --- a/src/app/MetaBrush/Action.hs +++ b/src/app/MetaBrush/Action.hs @@ -1,8 +1,11 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -24,11 +27,13 @@ import Data.Foldable import Data.Int ( Int32 ) import Data.Maybe - ( listToMaybe ) + ( catMaybes, fromMaybe ) import Data.Traversable ( for ) import Data.Word ( Word32 ) +import GHC.Generics + ( Generic ) -- acts import Data.Act @@ -59,9 +64,22 @@ import Data.Generics.Product.Fields -- gi-gdk import qualified GI.Gdk as GDK +-- gi-gio +import qualified GI.Gio as GIO + +-- gi-gobject +import qualified GI.GObject as GObject + -- gi-gtk import qualified GI.Gtk as GTK +-- haskell-gi-base +import qualified Data.GI.Base as GI + +-- hashable +import Data.Hashable + ( Hashable ) + -- lens import Control.Lens ( over, set ) @@ -129,9 +147,7 @@ import MetaBrush.UI.Coordinates import MetaBrush.UI.InfoBar ( updateInfoBar ) import {-# SOURCE #-} MetaBrush.UI.FileBar - ( TabLocation(..), newFileTab, removeFileTab ) -import MetaBrush.UI.Menu - ( MenuItem(..), Menu(..), ViewMenu(..) ) + ( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab ) import MetaBrush.UI.ToolBar ( Tool(..), Mode(..) ) import MetaBrush.UI.Viewport @@ -139,10 +155,22 @@ import MetaBrush.UI.Viewport import MetaBrush.Unique ( Unique ) import MetaBrush.Util - ( widgetAddClass, widgetAddClasses ) + ( (>=?=>), (>>?=) + , widgetAddClass, widgetAddClasses + ) -------------------------------------------------------------------------------- +data ActionName + = AppAction { actionSimpleName :: !Text } + | WinAction { actionSimpleName :: !Text } + deriving stock ( Eq, Ord, Show, Generic ) + deriving anyclass Hashable + +actionPrefix :: ActionName -> Text +actionPrefix ( AppAction _ ) = "app." +actionPrefix ( WinAction _ ) = "win." + class HandleAction action where handleAction :: UIElements -> Variables -> action -> IO () @@ -161,7 +189,7 @@ data NewFile = NewFile TabLocation instance HandleAction NewFile where handleAction uiElts vars ( NewFile tabLoc ) = - newFileTab False uiElts vars Nothing tabLoc + newFileTab uiElts vars Nothing tabLoc --------------- -- Open file -- @@ -178,41 +206,53 @@ instance HandleAction OpenFile where ( Just "Open" ) ( Just "Cancel" ) GTK.fileChooserSetSelectMultiple fileChooser True + GTK.fileChooserSetAction fileChooser GTK.FileChooserActionOpen GTK.nativeDialogSetModal fileChooser True fileFilter <- GTK.fileFilterNew GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" ) GTK.fileFilterAddPattern fileFilter "*.mb" GTK.fileChooserAddFilter fileChooser fileFilter - void $ GTK.nativeDialogRun fileChooser - filePaths <- GTK.fileChooserGetFilenames fileChooser - for_ filePaths \ filePath -> do - knownBrushes <- STM.atomically $ STM.readTVar brushesTVar - ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath - STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) - case mbDoc of - Left errMessage -> warningDialog window filePath errMessage - Right doc -> do - let - newDocHist :: DocumentHistory - newDocHist = newHistory doc - newFileTab False uiElts vars ( Just newDocHist ) tabLoc - updateHistoryState uiElts ( Just newDocHist ) + GTK.nativeDialogShow fileChooser + void $ GTK.afterNativeDialogResponse fileChooser \ response -> do + when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do + files <- GTK.fileChooserGetFiles fileChooser + nbFiles <- GIO.listModelGetNItems files + fileNames <- catMaybes <$> + for [ ( 0 :: Int ) .. fromIntegral nbFiles - 1 ] \ i -> + GIO.listModelGetItem files ( fromIntegral i ) >>?= + ( GI.castTo GIO.File >=?=> GIO.fileGetPath ) + for_ fileNames \ filePath -> do + knownBrushes <- STM.atomically $ STM.readTVar brushesTVar + ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath + STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) + case mbDoc of + Left errMessage -> warningDialog window filePath errMessage + Right doc -> do + let + newDocHist :: DocumentHistory + newDocHist = newHistory doc + newFileTab uiElts vars ( Just newDocHist ) tabLoc + updateHistoryState uiElts ( Just newDocHist ) + GObject.objectUnref files -warningDialog :: Show errMess => GTK.Window -> FilePath -> errMess -> IO () +warningDialog + :: ( Show errMess, GTK.IsWindow window ) + => window -> FilePath -> errMess -> IO () warningDialog window filePath errMess = do dialog <- GTK.new GTK.MessageDialog [] GTK.setMessageDialogText dialog ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) ) GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning - GTK.setWindowResizable dialog False + GTK.setWindowResizable dialog True GTK.setWindowDecorated dialog False GTK.windowSetTransientFor dialog ( Just window ) GTK.windowSetModal dialog True widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] closeButton <- GTK.dialogAddButton dialog "OK" 1 widgetAddClass closeButton "dialogButton" - _ <- GTK.dialogRun dialog - GTK.widgetDestroy dialog + GTK.widgetShow dialog + void $ GTK.afterDialogResponse dialog \ _ -> do + GTK.windowDestroy dialog ----------------- -- Open folder -- @@ -228,30 +268,34 @@ instance HandleAction OpenFolder where GTK.FileChooserActionSelectFolder ( Just "Select Folder" ) ( Just "Cancel" ) - GTK.fileChooserSetSelectMultiple fileChooser True + GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSelectFolder GTK.nativeDialogSetModal fileChooser True - void $ GTK.nativeDialogRun fileChooser - folderPaths <- GTK.fileChooserGetFilenames fileChooser - for_ folderPaths \ folderPath -> do - exists <- doesDirectoryExist folderPath - when exists do - filePaths <- listDirectory folderPath - for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do - knownBrushes <- STM.atomically $ STM.readTVar brushesTVar - ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath filePath ) - STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) - case mbDoc of - Left errMessage -> warningDialog window filePath errMessage - Right doc -> do - let - newDocHist :: DocumentHistory - newDocHist = newHistory doc - newFileTab False uiElts vars ( Just newDocHist ) tabLoc - updateHistoryState uiElts ( Just newDocHist ) + GTK.nativeDialogShow fileChooser + void $ GTK.afterNativeDialogResponse fileChooser \ response -> do + when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do + folder <- GTK.fileChooserGetFile fileChooser + mbFolderPath <- GIO.fileGetPath folder + for_ mbFolderPath \ folderPath -> do + exists <- doesDirectoryExist folderPath + when exists do + filePaths <- listDirectory folderPath + for_ filePaths \ filePath -> when ( takeExtension filePath == ".mb" ) do + knownBrushes <- STM.atomically $ STM.readTVar brushesTVar + ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes ( folderPath filePath ) + STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) + case mbDoc of + Left errMessage -> warningDialog window filePath errMessage + Right doc -> do + let + newDocHist :: DocumentHistory + newDocHist = newHistory doc + newFileTab uiElts vars ( Just newDocHist ) tabLoc + updateHistoryState uiElts ( Just newDocHist ) + GObject.objectUnref folder ---------------- --- Save file -- ---------------- +-------------------- +-- Save & Save as -- +-------------------- data Save = Save deriving stock Show @@ -260,6 +304,12 @@ instance HandleAction Save where handleAction uiElts vars _ = save uiElts vars True +data SaveAs = SaveAs + deriving stock Show + +instance HandleAction SaveAs where + handleAction uiElts vars _ = saveAs uiElts vars True + save :: UIElements -> Variables -> Bool -> IO () save uiElts vars keepOpen = do mbDoc <- fmap present <$> STM.atomically ( activeDocument vars ) @@ -276,48 +326,42 @@ save uiElts vars keepOpen = do modif = if keepOpen then SaveDocument Nothing else CloseDocument pure $ UpdateDocAndThen modif ( saveDocument filePath doc ) -------------- --- Save as -- -------------- - -data SaveAs = SaveAs - deriving stock Show - -instance HandleAction SaveAs where - handleAction uiElts vars _ = saveAs uiElts vars True - saveAs :: UIElements -> Variables -> Bool -> IO () -saveAs uiElts vars keepOpen = do - mbSavePath <- askForSavePath uiElts - for_ mbSavePath \ savePath -> +saveAs uiElts vars keepOpen = + withSavePath uiElts \ savePath -> modifyingCurrentDocument uiElts vars \ doc -> do let modif :: DocumentUpdate modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument pure $ UpdateDocAndThen modif ( saveDocument savePath doc ) -askForSavePath :: UIElements -> IO ( Maybe FilePath ) -askForSavePath ( UIElements {..} ) = do +withSavePath :: UIElements -> ( FilePath -> IO () ) -> IO () +withSavePath ( UIElements {..} ) action = do fileChooser <- GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.FileChooserActionSave ( Just "Save" ) ( Just "Cancel" ) GTK.nativeDialogSetModal fileChooser True - GTK.fileChooserSetDoOverwriteConfirmation fileChooser True + GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSave fileFilter <- GTK.fileFilterNew GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" ) GTK.fileFilterAddPattern fileFilter "*.mb" GTK.fileChooserAddFilter fileChooser fileFilter - void $ GTK.nativeDialogRun fileChooser - fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames fileChooser - where - fullFilePath :: FilePath -> FilePath - fullFilePath fp - | ".mb" <- takeExtension fp - = fp - | otherwise - = fp <.> "mb" + GTK.nativeDialogShow fileChooser + void $ GTK.afterNativeDialogResponse fileChooser \ response -> do + when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do + saveFile <- GTK.fileChooserGetFile fileChooser + mbSavePath <- fmap fullFilePath <$> GIO.fileGetPath saveFile + for_ mbSavePath action + GObject.objectUnref saveFile + where + fullFilePath :: FilePath -> FilePath + fullFilePath fp + | ".mb" <- takeExtension fp + = fp + | otherwise + = fp <.> "mb" ----------- -- Close -- @@ -326,7 +370,7 @@ askForSavePath ( UIElements {..} ) = do data Close = CloseActive -- ^ Close active document. | CloseThis -- ^ Close a specific tab. - { docToClose :: Unique } + { docToClose :: !Unique } deriving stock Show pattern JustClose, SaveAndClose, CancelClose :: Int32 @@ -364,19 +408,20 @@ instance HandleAction Close where cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose GTK.dialogSetDefaultResponse dialog 1 for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" - choice <- GTK.dialogRun dialog - GTK.widgetDestroy dialog - case choice of - JustClose -> closeDocument isActiveDoc documentUnique - SaveAndClose -> save uiElts vars False - _ -> pure () + GTK.widgetShow dialog + void $ GTK.onDialogResponse dialog \ choice -> do + case choice of + JustClose -> closeDocument isActiveDoc documentUnique + SaveAndClose -> save uiElts vars False + _ -> pure () + GTK.windowDestroy dialog | otherwise -> closeDocument isActiveDoc documentUnique where closeDocument :: Bool -> Unique -> IO () closeDocument isActiveDoc unique = do - removeFileTab vars unique + removeFileTab uiElts vars unique when isActiveDoc do uiUpdateAction <- STM.atomically do STM.writeTVar activeDocumentTVar Nothing @@ -390,22 +435,43 @@ instance HandleAction Close where -- Switch document -- --------------------- -data SwitchTo = SwitchTo Unique +data SwitchFromTo = + SwitchFromTo + { mbPrevActiveDocUnique :: !( Maybe Unique ) + , newActiveDocUnique :: !Unique + } deriving stock Show -instance HandleAction SwitchTo where +instance HandleAction SwitchFromTo where handleAction uiElts vars@( Variables {..} ) - ( SwitchTo newUnique ) = do - uiUpdateAction <- STM.atomically do - STM.writeTVar activeDocumentTVar ( Just newUnique ) - mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar - uiUpdateAction <- updateUIAction uiElts vars - pure do - uiUpdateAction - updateHistoryState uiElts mbHist - uiUpdateAction + ( SwitchFromTo { mbPrevActiveDocUnique, newActiveDocUnique } ) + | mbPrevActiveDocUnique == Just newActiveDocUnique + = do + mbActiveTab <- Map.lookup newActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar + for_ mbActiveTab \ ( FileBarTab { fileBarTab = activeTab, fileBarTabButton = activeTabButton } ) -> do + GTK.toggleButtonSetActive activeTabButton True + flags <- GTK.widgetGetStateFlags activeTab + GTK.widgetSetStateFlags activeTab + ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags ) + True + | otherwise + = do + uiUpdateAction <- STM.atomically do + STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique ) + mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar + uiUpdateAction <- updateUIAction uiElts vars + pure do + uiUpdateAction + for_ mbPrevActiveDocUnique \ prevActiveDocUnique -> do + mbPrevActiveTab <- Map.lookup prevActiveDocUnique <$> STM.readTVarIO fileBarTabsTVar + for_ mbPrevActiveTab \ ( FileBarTab { fileBarTab = prevActiveTab, fileBarTabButton = prevActiveTabButton } ) -> do + GTK.toggleButtonSetActive prevActiveTabButton False + flags <- GTK.widgetGetStateFlags prevActiveTab + GTK.widgetSetStateFlags prevActiveTab ( filter (/= GTK.StateFlagsActive) flags ) True + updateHistoryState uiElts mbHist + uiUpdateAction -------------- -- Quitting -- @@ -415,10 +481,11 @@ data Quit = Quit deriving stock Show instance HandleAction Quit where - handleAction ( UIElements { window } ) _ _ = quitEverything window + handleAction ( UIElements { application, window } ) _ _ = + quitEverything application window -quitEverything :: GTK.Window -> IO () -quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit +quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO () +quitEverything = GTK.applicationRemoveWindow ---------------- -- Undo & Redo -- @@ -556,17 +623,20 @@ data ToggleGuides = ToggleGuides deriving stock Show instance HandleAction ToggleGuides where - handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do - guidesWereShown <- STM.atomically do + handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do + _guidesWereShown <- STM.atomically do guidesWereShown <- STM.readTVar showGuidesTVar STM.writeTVar showGuidesTVar ( not guidesWereShown ) pure guidesWereShown - let - newText :: Text - newText - | guidesWereShown = "Show guides" - | otherwise = "Hide guides" - GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText + --let + -- newText :: Text + -- newText + -- | guidesWereShown = "Show guides" + -- | otherwise = "Hide guides" + -- toggleGuidesWidget :: GTK.Button + -- toggleGuidesWidget = menuItemWidget . toggleGuides . sectionItems . viewMenu4 . menuItemSubmenu . view + -- $ menuObject + --GTK.buttonSetLabel toggleGuidesWidget newText STM.atomically ( STM.writeTVar recomputeStrokesTVar True ) for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do GTK.widgetQueueDraw drawingArea @@ -813,7 +883,7 @@ instance HandleAction MouseRelease where 1 -> do viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea - modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do + modifyingCurrentDocument uiElts vars \ doc@( Document { zoomFactor, viewportCenter } ) -> do let toViewport :: Point2D Double -> Point2D Double toViewport = toViewportCoordinates zoomFactor ( viewportWidth, viewportHeight ) viewportCenter @@ -835,7 +905,8 @@ instance HandleAction MouseRelease where changeText = "Create guide" pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) | otherwise - -> pure Don'tModifyDoc + -> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc ) + -- ^^ force an UI update when releasing a guide inside a ruler area where createGuide :: Bool createGuide @@ -991,29 +1062,27 @@ instance HandleAction MouseRelease where -- Scrolling -- --------------- -data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) +data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double ) deriving stock Show instance HandleAction Scroll where handleAction - uiElts@( UIElements { viewport = Viewport {..} } ) + uiElts vars@( Variables {..} ) - ( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do + ( Scroll mbMousePos ( Vector2D dx dy ) ) = do - viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea - viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea + --viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea + --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea unless ( dx == 0 && dy == 0 ) do modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do modifiers <- STM.readTVar modifiersTVar let - toViewport :: Point2D Double -> Point2D Double - toViewport = toViewportCoordinates oldZoomFactor ( viewportWidth, viewportHeight ) oldCenter - -- Mouse position in the coordinate system of the document (not the drawing area GTK coordinates) mousePos :: Point2D Double - mousePos = toViewport ( Point2D x y ) + mousePos = fromMaybe oldCenter mbMousePos + finalMousePos :: Point2D Double newDoc :: Document - newDoc + ( newDoc, finalMousePos ) -- Zooming using 'Control'. | any ( \ case { Control _ -> True; _ -> False } ) modifiers = let @@ -1027,28 +1096,21 @@ instance HandleAction Scroll where newCenter = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) • oldCenter - in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } + in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos ) -- Vertical scrolling turned into horizontal scrolling using 'Shift'. | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers = let newCenter :: Point2D Double newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter - in doc { viewportCenter = newCenter } + in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos ) -- Vertical scrolling. | otherwise = let newCenter :: Point2D Double newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter - in doc { viewportCenter = newCenter } - finalZoomFactor :: Double - finalZoomFactor = zoomFactor newDoc - finalCenter :: Point2D Double - finalCenter = viewportCenter newDoc - toFinalViewport :: Point2D Double -> Point2D Double - toFinalViewport = toViewportCoordinates finalZoomFactor ( viewportWidth, viewportHeight ) finalCenter - finalMousePos :: Point2D Double - finalMousePos = toFinalViewport ( Point2D x y ) - STM.writeTVar mousePosTVar ( Just finalMousePos ) + in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos ) + for_ mbMousePos \ _ -> + STM.writeTVar mousePosTVar ( Just finalMousePos ) pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) -------------------- @@ -1067,7 +1129,7 @@ instance HandleAction KeyboardPress where for_ ( modifierKey keyCode ) ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert ) - case keyCode of + case fromIntegral keyCode of GDK.KEY_Escape -> handleAction uiElts vars Quit diff --git a/src/app/MetaBrush/Action.hs-boot b/src/app/MetaBrush/Action.hs-boot index ab0058b..ed32f47 100644 --- a/src/app/MetaBrush/Action.hs-boot +++ b/src/app/MetaBrush/Action.hs-boot @@ -1,3 +1,5 @@ +{-# LANGUAGE MonoLocalBinds #-} + module MetaBrush.Action where -- base @@ -7,6 +9,14 @@ import Data.Word -- gi-gtk import qualified GI.Gtk as GTK +-- hashable +import Data.Hashable + ( Hashable ) + +-- text +import Data.Text + ( Text ) + -- MetaBrush import Math.Vector2D ( Point2D, Vector2D ) @@ -21,6 +31,15 @@ import MetaBrush.Unique -------------------------------------------------------------------------------- +data ActionName + = AppAction { actionSimpleName :: !Text } + | WinAction { actionSimpleName :: !Text } + +instance Eq ActionName +instance Ord ActionName +instance Show ActionName +instance Hashable ActionName + class HandleAction action where handleAction :: UIElements -> Variables -> action -> IO () @@ -44,15 +63,19 @@ instance HandleAction SaveAs data Close = CloseActive | CloseThis - { docToClose :: Unique } + { docToClose :: !Unique } instance HandleAction Close -data SwitchTo = SwitchTo Unique -instance HandleAction SwitchTo +data SwitchFromTo = + SwitchFromTo + { mbPrevActiveDocUnique :: !( Maybe Unique ) + , newActiveDocUnique :: !Unique + } +instance HandleAction SwitchFromTo data Quit = Quit instance HandleAction Quit -quitEverything :: GTK.Window -> IO () +quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO () data Undo = Undo instance HandleAction Undo @@ -99,7 +122,7 @@ instance HandleAction MouseClick data MouseRelease = MouseRelease Word32 ( Point2D Double ) instance HandleAction MouseRelease -data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) +data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double ) instance HandleAction Scroll data KeyboardPress = KeyboardPress Word32 diff --git a/src/app/MetaBrush/Application.hs b/src/app/MetaBrush/Application.hs new file mode 100644 index 0000000..76625e7 --- /dev/null +++ b/src/app/MetaBrush/Application.hs @@ -0,0 +1,498 @@ + +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +module MetaBrush.Application + ( runApplication ) + where + +-- base +import Control.Monad + ( forever, void ) +import Control.Monad.ST + ( stToIO ) +import Data.Foldable + ( for_ ) +import Data.Function + ( (&) ) +import Data.Int + ( Int32 ) +import GHC.Conc + ( forkIO ) + +-- containers +import Data.Map.Strict + ( Map ) +import qualified Data.Map.Strict as Map + ( empty ) +import qualified Data.Sequence as Seq + ( fromList ) +import Data.Set + ( Set ) +import qualified Data.Set as Set + ( empty ) + +-- directory +import qualified System.Directory as Directory + ( canonicalizePath ) + +-- filepath +import System.FilePath + ( () ) + +-- generic-lens +import Data.Generics.Product.Fields + ( field' ) + +-- gi-cairo-render +import qualified GI.Cairo.Render as Cairo + ( Render ) + +-- gi-cairo-connector +import qualified GI.Cairo.Render.Connector as Cairo + ( renderWithContext ) + +-- gi-glib +import qualified GI.GLib as GLib + +-- gi-gtk +import qualified GI.Gtk as GTK + +-- lens +import Control.Lens + ( (.~) ) +import Control.Lens.At + ( at ) + +-- stm +import qualified Control.Concurrent.STM as STM + ( atomically, retry ) +import qualified Control.Concurrent.STM.TVar as STM + ( newTVarIO, readTVar, writeTVar ) + +-- superrecord +import qualified SuperRecord as Super + ( Rec ) +import qualified SuperRecord + ( (:=)(..), (&), rnil ) + +-- text +import qualified Data.Text as Text + ( pack ) + +-- transformers +import Control.Monad.Trans.Reader + ( runReaderT ) + +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap + ( fromList ) + +-- MetaBrush +import Math.Bezier.Cubic.Fit + ( FitParameters(..) ) +import Math.Bezier.Spline + ( Spline(..), Curves(..), Curve(..), NextPoint(..) ) +import Math.Bezier.Stroke + ( invalidateCache ) +import Math.Vector2D + ( Point2D(..) ) +import MetaBrush.Action + ( ActionOrigin(..) ) +import qualified MetaBrush.Asset.Brushes as Asset.Brushes + ( circle ) +import MetaBrush.Asset.Colours + ( getColours ) +import MetaBrush.Asset.Logo + ( drawLogo ) +import MetaBrush.Brush + ( Brush, newBrushReference ) +import MetaBrush.Context + ( UIElements(..), Variables(..) + , Modifier(..) + , HoldAction(..), PartialPath(..) + ) +import MetaBrush.Document + ( emptyDocument + , Stroke(..), FocusState(..) + , PointData(..) + ) +import MetaBrush.Document.History + ( DocumentHistory(..), newHistory ) +import MetaBrush.Document.Update + ( activeDocument, withActiveDocument ) +import MetaBrush.Event + ( handleEvents ) +import MetaBrush.Render.Document + ( blankRender, getDocumentRender ) +import MetaBrush.Render.Rulers + ( renderRuler ) +import MetaBrush.UI.FileBar + ( FileBar(..), FileBarTab, createFileBar ) +import MetaBrush.UI.InfoBar + ( InfoBar(..), createInfoBar, updateInfoBar ) +import MetaBrush.UI.Menu + ( createMenuBar, createMenuActions ) +import MetaBrush.UI.Panels + ( createPanelBar ) +import MetaBrush.UI.ToolBar + ( Tool(..), Mode(..), createToolBar ) +import MetaBrush.UI.Viewport + ( Viewport(..), ViewportEventControllers(..) + , Ruler(..) + , createViewport + ) +import MetaBrush.Unique + ( newUniqueSupply + , Unique, freshUnique + , uniqueMapFromList + ) +import MetaBrush.Util + ( widgetAddClass, widgetAddClasses ) +import qualified Paths_MetaBrush as Cabal + ( getDataDir, getDataFileName ) + +-------------------------------------------------------------------------------- + +runApplication :: GTK.Application -> IO () +runApplication application = do + + --------------------------------------------------------- + -- Initialise state + + uniqueSupply <- newUniqueSupply + + circleBrush <- Asset.Brushes.circle uniqueSupply + circleBrushUnique <- runReaderT freshUnique uniqueSupply + docUnique <- runReaderT freshUnique uniqueSupply + strokeUnique <- runReaderT freshUnique uniqueSupply + + let + + testBrushes :: HashMap Brush Unique + testBrushes = HashMap.fromList + [ ( circleBrush, circleBrushUnique ) ] + + testDocuments :: Map Unique DocumentHistory + testDocuments = fmap newHistory $ uniqueMapFromList + [ emptyDocument "Test" docUnique + & ( field' @"documentContent" . field' @"strokes" ) .~ + [ Stroke + { strokeName = "Stroke 1" + , strokeVisible = True + , strokeUnique = strokeUnique + , strokeBrushRef = newBrushReference @'[ "r" SuperRecord.:= Double ] circleBrushUnique + , strokeSpline = + Spline + { splineStart = mkPoint ( Point2D 10 -20 ) 2 + , splineCurves = OpenCurves $ Seq.fromList + [ LineTo { curveEnd = NextPoint ( mkPoint ( Point2D 10 10 ) 5 ), curveData = invalidateCache undefined } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 10 ) 5 ), curveData = invalidateCache undefined } + , LineTo { curveEnd = NextPoint ( mkPoint ( Point2D -10 -20 ) 2 ), curveData = invalidateCache undefined } + ] + } + } + ] + & ( field' @"documentBrushes" . at circleBrushUnique ) .~ ( Just circleBrush ) + ] + where + mkPoint :: Point2D Double -> Double -> PointData ( Super.Rec '[ "r" SuperRecord.:= Double ] ) + mkPoint pt r = PointData pt Normal ( #r SuperRecord.:= r SuperRecord.& SuperRecord.rnil ) + + recomputeStrokesTVar <- STM.newTVarIO @Bool False + documentRenderTVar <- STM.newTVarIO @( ( Int32, Int32 ) -> Cairo.Render () ) ( const $ pure () ) + activeDocumentTVar <- STM.newTVarIO @( Maybe Unique ) Nothing + openDocumentsTVar <- STM.newTVarIO @( Map Unique DocumentHistory ) testDocuments + brushesTVar <- STM.newTVarIO @( HashMap Brush Unique ) testBrushes + mousePosTVar <- STM.newTVarIO @( Maybe ( Point2D Double ) ) Nothing + mouseHoldTVar <- STM.newTVarIO @( Maybe HoldAction ) Nothing + modifiersTVar <- STM.newTVarIO @( Set Modifier ) Set.empty + toolTVar <- STM.newTVarIO @Tool Selection + modeTVar <- STM.newTVarIO @Mode PathMode + debugTVar <- STM.newTVarIO @Bool False + partialPathTVar <- STM.newTVarIO @( Maybe PartialPath ) Nothing + fileBarTabsTVar <- STM.newTVarIO @( Map Unique FileBarTab ) Map.empty + showGuidesTVar <- STM.newTVarIO @Bool True + maxHistorySizeTVar <- STM.newTVarIO @Int 1000 + fitParametersTVar <- STM.newTVarIO @FitParameters + ( FitParameters + { maxSubdiv = 6 + , nbSegments = 12 + , dist_tol = 5e-3 + , t_tol = 1e-4 + , maxIters = 100 + } + ) + + -- Put all these stateful variables in a record for conciseness. + let + variables :: Variables + variables = Variables {..} + + --------------------------------------------------------- + -- GTK UI + + window <- GTK.applicationWindowNew application + display <- GTK.rootGetDisplay window + + dataPath <- Directory.canonicalizePath =<< Cabal.getDataDir + themePath <- Text.pack <$> ( Directory.canonicalizePath =<< Cabal.getDataFileName "theme.css" ) + cssProvider <- GTK.cssProviderNew + GTK.cssProviderLoadFromPath cssProvider themePath + GTK.styleContextAddProviderForDisplay display cssProvider 1000 + + windowKeys <- GTK.eventControllerKeyNew + + GTK.eventControllerSetPropagationPhase windowKeys GTK.PropagationPhaseBubble + + widgetAddClasses window [ "metabrush", "window" ] + GTK.setWindowResizable window True + GTK.setWindowDecorated window True + GTK.setWindowTitle window "MetaBrush" + GTK.windowSetDefaultSize window 1024 768 + + GTK.windowSetIconName window ( Just "MetaBrush" ) + iconTheme <- GTK.iconThemeGetForDisplay display + GTK.iconThemeAddSearchPath iconTheme ( dataPath "icons" ) + + colours <- getColours cssProvider + + --------------------------------------------------------- + -- Create base UI elements + + baseOverlay <- GTK.overlayNew + GTK.windowSetChild window ( Just baseOverlay ) + + uiGrid <- GTK.gridNew + GTK.overlaySetChild baseOverlay ( Just uiGrid ) + + toolBar <- GTK.boxNew GTK.OrientationVertical 0 + mainPane <- GTK.panedNew GTK.OrientationHorizontal + panelBox <- GTK.boxNew GTK.OrientationVertical 0 + + GTK.gridAttach uiGrid toolBar 0 0 2 1 + GTK.gridAttach uiGrid mainPane 2 0 1 1 + + mainView <- GTK.boxNew GTK.OrientationVertical 0 + + GTK.panedSetStartChild mainPane mainView + GTK.panedSetEndChild mainPane panelBox + + viewportGrid <- GTK.gridNew + + --------------------------------------------------------- + -- Background + + widgetAddClass uiGrid "bg" + + --------------------------------------------------------- + -- Title bar + + titleBar <- GTK.headerBarNew + + GTK.windowSetTitlebar window ( Just titleBar ) + widgetAddClass titleBar "titleBar" + + logo <- GTK.boxNew GTK.OrientationVertical 0 + GTK.headerBarPackStart titleBar logo + + GTK.headerBarSetShowTitleButtons titleBar False + GTK.headerBarSetDecorationLayout titleBar ( Just "icon:minimize,maximize,close" ) + + titleLabel <- GTK.labelNew ( Just "MetaBrush" ) + GTK.widgetSetHexpand titleLabel True + widgetAddClasses titleLabel [ "text", "title", "plain" ] + GTK.headerBarSetTitleWidget titleBar ( Just titleLabel ) + + -------- + -- Logo + + widgetAddClass logo "logo" + + logoArea <- GTK.drawingAreaNew + GTK.boxAppend logo logoArea + + GTK.widgetSetHexpand logoArea True + GTK.widgetSetVexpand logoArea True + + GTK.drawingAreaSetDrawFunc logoArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawLogo colours ) cairoContext + + GTK.widgetQueueDraw logoArea + + --------------------------------------------------------- + -- Main viewport + + viewport@( Viewport {..} ) <- createViewport viewportGrid + + ----------------- + -- Viewport rendering + + -- Update the document render data in a separate thread. + _ <- forkIO $ forever do + getRenderDoc <- STM.atomically do + needsRecomputation <- STM.readTVar recomputeStrokesTVar + case needsRecomputation of + False -> STM.retry + True -> do + mbDocNow <- fmap present <$> activeDocument variables + case mbDocNow of + Nothing -> pure ( pure . const $ blankRender colours ) + Just doc -> do + modifiers <- STM.readTVar modifiersTVar + mbMousePos <- STM.readTVar mousePosTVar + mbHoldAction <- STM.readTVar mouseHoldTVar + mbPartialPath <- STM.readTVar partialPathTVar + mode <- STM.readTVar modeTVar + showGuides <- STM.readTVar showGuidesTVar + debug <- STM.readTVar debugTVar + fitParameters <- STM.readTVar fitParametersTVar + STM.writeTVar recomputeStrokesTVar False + let + addRulers :: ( ( Int32, Int32 ) -> Cairo.Render () ) -> ( ( Int32, Int32 ) -> Cairo.Render () ) + addRulers newRender viewportSize = do + newRender viewportSize + renderRuler + colours viewportSize ViewportOrigin viewportSize + mbMousePos mbHoldAction showGuides + doc + pure + ( addRulers <$> getDocumentRender + colours fitParameters mode debug + modifiers mbMousePos mbHoldAction mbPartialPath + doc + ) + renderDoc <- stToIO getRenderDoc + STM.atomically do + STM.writeTVar documentRenderTVar renderDoc + void do + GLib.idleAdd GLib.PRIORITY_HIGH_IDLE do + for_ + [ viewportDrawingArea + , rulerCornerDrawingArea + , topRulerDrawingArea + , leftRulerDrawingArea + ] + GTK.widgetQueueDraw + pure False + + -- Render the document using the latest available draw data. + GTK.drawingAreaSetDrawFunc viewportDrawingArea $ Just \ _ cairoContext _ _ -> void $ do + viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea + -- Get the Cairo instructions for rendering the current document + mbDoc <- fmap present <$> STM.atomically ( activeDocument variables ) + render <- case mbDoc of + Nothing -> pure ( blankRender colours ) + Just _ -> STM.atomically do + render <- STM.readTVar documentRenderTVar + pure ( render ( viewportWidth, viewportHeight ) ) + Cairo.renderWithContext render cairoContext + + for_ + [ ( rulerCornerDrawingArea , RulerCorner ) + , ( topRulerDrawingArea , TopRuler ) + , ( leftRulerDrawingArea , LeftRuler ) + ] + ( \ ( rulerDrawingArea, ruler ) -> + GTK.drawingAreaSetDrawFunc rulerDrawingArea $ Just \ _ cairoContext _ _ -> void do + viewportWidth <- GTK.widgetGetAllocatedWidth viewportDrawingArea + viewportHeight <- GTK.widgetGetAllocatedHeight viewportDrawingArea + width <- GTK.widgetGetAllocatedWidth rulerDrawingArea + height <- GTK.widgetGetAllocatedHeight rulerDrawingArea + mbRender <- STM.atomically $ withActiveDocument variables \ doc -> do + mbMousePos <- STM.readTVar mousePosTVar + mbHoldAction <- STM.readTVar mouseHoldTVar + showGuides <- STM.readTVar showGuidesTVar + pure do + renderRuler + colours ( viewportWidth, viewportHeight ) ( RulerOrigin ruler ) ( width, height ) + mbMousePos mbHoldAction showGuides + doc + for_ mbRender \ render -> + Cairo.renderWithContext render cairoContext + ) + + --------------------------------------------------------- + -- Tool bar + + _ <- createToolBar variables colours toolBar + + --------------------------------------------------------- + -- Info bar + + infoBar@( InfoBar { infoBarArea } ) <- createInfoBar colours + + menuActions <- createMenuActions + + rec + + --------------------------------------------------------- + -- File bar + + fileBar@( FileBar { fileBarBox } ) <- + createFileBar + colours variables + application window windowKeys titleBar titleLabel viewport infoBar + menuBar menuActions + + let + uiElements :: UIElements + uiElements = UIElements {..} + + ------------ + -- Menu bar + + menuBar <- createMenuBar uiElements variables colours + + GTK.boxAppend mainView fileBarBox + GTK.boxAppend mainView viewportGrid + GTK.boxAppend mainView infoBarArea + + --------------------------------------------------------- + -- Panels + + createPanelBar panelBox + + --------------------------------------------------------- + -- Actions + + handleEvents uiElements variables + + --------------------------------------------------------- + -- Finishing up + + mbDoc <- fmap present <$> ( STM.atomically $ activeDocument variables ) + updateInfoBar viewportDrawingArea infoBar variables mbDoc -- need to update the info bar after widgets have been realized + + GTK.widgetShow window + + GTK.widgetSetCanFocus viewportDrawingArea True + GTK.widgetSetFocusOnClick viewportDrawingArea True + GTK.widgetSetFocusable viewportDrawingArea True + _ <- GTK.widgetGrabFocus viewportDrawingArea + + -- need to add the controllers after the callbacks have been registered + GTK.widgetAddController window windowKeys + GTK.widgetAddController viewportDrawingArea ( viewportMotionController viewportEventControllers ) + GTK.widgetAddController viewportDrawingArea ( viewportScrollController viewportEventControllers ) + GTK.widgetAddController viewportDrawingArea ( viewportClicksController viewportEventControllers ) + GTK.widgetAddController rulerCornerDrawingArea ( viewportMotionController rulerCornerEventControllers ) + GTK.widgetAddController rulerCornerDrawingArea ( viewportScrollController rulerCornerEventControllers ) + GTK.widgetAddController rulerCornerDrawingArea ( viewportClicksController rulerCornerEventControllers ) + GTK.widgetAddController leftRulerDrawingArea ( viewportMotionController leftRulerEventControllers ) + GTK.widgetAddController leftRulerDrawingArea ( viewportScrollController leftRulerEventControllers ) + GTK.widgetAddController leftRulerDrawingArea ( viewportClicksController leftRulerEventControllers ) + GTK.widgetAddController topRulerDrawingArea ( viewportMotionController topRulerEventControllers ) + GTK.widgetAddController topRulerDrawingArea ( viewportScrollController topRulerEventControllers ) + GTK.widgetAddController topRulerDrawingArea ( viewportClicksController topRulerEventControllers ) diff --git a/src/app/MetaBrush/Asset/Colours.hs b/src/app/MetaBrush/Asset/Colours.hs index ca2fc53..b46e204 100644 --- a/src/app/MetaBrush/Asset/Colours.hs +++ b/src/app/MetaBrush/Asset/Colours.hs @@ -1,13 +1,13 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module MetaBrush.Asset.Colours - ( ColourRecord(..), ColourType + ( ColourRecord(..) , Colours, getColours ) where @@ -42,61 +42,53 @@ data ColourRecord a } deriving stock ( Show, Functor, Foldable, Traversable ) -data ColourType - = Colour - | BackgroundColour - deriving stock Show - -data ColourName - = ColourName - { colourName :: !Text - , colourType :: !ColourType - , stateFlags :: ![ GTK.StateFlags ] - } +newtype ColourName + = ColourName { colourName :: Text } deriving stock Show colourNames :: ColourRecord ColourName colourNames = Colours - { bg = ColourName "bg" BackgroundColour [ GTK.StateFlagsNormal ] - , active = ColourName "active" BackgroundColour [ GTK.StateFlagsNormal ] - , close = ColourName "close" Colour [ GTK.StateFlagsNormal ] - , highlight = ColourName "highlight" Colour [ GTK.StateFlagsNormal ] - , cursor = ColourName "cursor" Colour [ GTK.StateFlagsNormal ] - , cursorOutline = ColourName "cursorStroke" Colour [ GTK.StateFlagsNormal ] - , cursorIndicator = ColourName "cursorIndicator" Colour [ GTK.StateFlagsNormal ] - , plain = ColourName "plain" Colour [ GTK.StateFlagsNormal ] - , base = ColourName "base" Colour [ GTK.StateFlagsNormal ] - , splash = ColourName "splash" Colour [ GTK.StateFlagsNormal ] - , pathPoint = ColourName "pathPoint" Colour [ GTK.StateFlagsNormal ] - , pathPointOutline = ColourName "pathPointStroke" Colour [ GTK.StateFlagsNormal ] - , controlPoint = ColourName "controlPoint" Colour [ GTK.StateFlagsNormal ] - , controlPointOutline = ColourName "controlPointStroke" Colour [ GTK.StateFlagsNormal ] - , path = ColourName "path" Colour [ GTK.StateFlagsNormal ] - , brush = ColourName "brush" Colour [ GTK.StateFlagsNormal ] - , brushStroke = ColourName "brushStroke" Colour [ GTK.StateFlagsNormal ] - , brushCenter = ColourName "brushCenter" Colour [ GTK.StateFlagsNormal ] - , pointHover = ColourName "pointHover" Colour [ GTK.StateFlagsNormal ] - , pointSelected = ColourName "pointSelected" Colour [ GTK.StateFlagsNormal ] - , viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ] - , viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] - , tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] - , rulerBg = ColourName "ruler" BackgroundColour [ GTK.StateFlagsNormal ] - , rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ] - , guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ] - , magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] - , glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ] - , selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ] - , selectedOutline = ColourName "selectedOutline" Colour [ GTK.StateFlagsNormal ] + { bg = ColourName "bg" + , active = ColourName "active" + , close = ColourName "close" + , highlight = ColourName "highlight" + , cursor = ColourName "cursor" + , cursorOutline = ColourName "cursorStroke" + , cursorIndicator = ColourName "cursorIndicator" + , plain = ColourName "plain" + , base = ColourName "base" + , splash = ColourName "splash" + , pathPoint = ColourName "pathPoint" + , pathPointOutline = ColourName "pathPointStroke" + , controlPoint = ColourName "controlPoint" + , controlPointOutline = ColourName "controlPointStroke" + , path = ColourName "path" + , brush = ColourName "brush" + , brushStroke = ColourName "brushStroke" + , brushCenter = ColourName "brushCenter" + , pointHover = ColourName "pointHover" + , pointSelected = ColourName "pointSelected" + , viewport = ColourName "viewport" + , viewportScrollbar = ColourName "viewportScrollbar" + , tabScrollbar = ColourName "tabScrollbar" + , rulerBg = ColourName "ruler" + , rulerTick = ColourName "rulerTick" + , guide = ColourName "guide" + , magnifier = ColourName "magnifier" + , glass = ColourName "glass" + , selected = ColourName "selected" + , selectedOutline = ColourName "selectedOutline" } type Colours = ColourRecord GDK.RGBA -getColours :: GTK.WidgetPath -> IO Colours -getColours windowWidgetPath = - for colourNames \ ( ColourName {..} ) -> do - style <- GTK.styleContextNew - GTK.styleContextSetPath style windowWidgetPath +getColours + :: ( GTK.IsStyleProvider styleProvider ) + => styleProvider -> IO Colours +getColours provider = + for colourNames \ ( ColourName { colourName } ) -> do + widget <- GTK.fixedNew + style <- GTK.widgetGetStyleContext widget + GTK.styleContextAddProvider style provider ( fromIntegral GTK.STYLE_PROVIDER_PRIORITY_USER ) GTK.styleContextAddClass style colourName - case colourType of - BackgroundColour -> GTK.styleContextGetBackgroundColor style stateFlags - Colour -> GTK.styleContextGetColor style stateFlags + GTK.styleContextGetColor style diff --git a/src/app/MetaBrush/Context.hs b/src/app/MetaBrush/Context.hs index 91a93ab..0bf6c63 100644 --- a/src/app/MetaBrush/Context.hs +++ b/src/app/MetaBrush/Context.hs @@ -3,7 +3,7 @@ module MetaBrush.Context ( UIElements(..), Variables(..) - , LR(..), Modifier(..), modifierKey, modifierType + , LR(..), Modifier(..), modifierKey , HoldAction(..), GuideAction(..), PartialPath(..) ) where @@ -24,9 +24,12 @@ import Data.Map.Strict import qualified GI.Cairo.Render as Cairo ( Render ) --- gi-gtk +-- gi-gdk import qualified GI.Gdk as GDK +-- gi-gio +import qualified GI.Gio as GIO + -- gi-gtk import qualified GI.Gtk as GTK @@ -43,6 +46,8 @@ import Math.Bezier.Cubic.Fit ( FitParameters ) import Math.Vector2D ( Point2D ) +import {-# SOURCE #-} MetaBrush.Action + ( ActionName ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Brush @@ -54,11 +59,9 @@ import MetaBrush.Document.History import MetaBrush.Document.Selection ( DragMoveSelect ) import {-# SOURCE #-} MetaBrush.UI.FileBar - ( FileBar ) + ( FileBar, FileBarTab ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) -import {-# SOURCE #-} MetaBrush.UI.Menu - ( Menu, ResourceType(Object) ) import {-# SOURCE #-} MetaBrush.UI.ToolBar ( Tool, Mode ) import MetaBrush.UI.Viewport @@ -70,35 +73,38 @@ import MetaBrush.Unique data UIElements = UIElements - { window :: !GTK.Window - , title :: !GTK.Label - , titleBar :: !GTK.Box - , fileBar :: !FileBar - , viewport :: !Viewport - , infoBar :: !InfoBar - , menu :: Menu Object -- needs to be lazy for "recursive do" - , colours :: !Colours + { application :: !GTK.Application + , window :: !GTK.ApplicationWindow + , windowKeys :: !GTK.EventControllerKey + , titleBar :: !GTK.HeaderBar + , titleLabel :: !GTK.Label + , fileBar :: !FileBar + , viewport :: !Viewport + , infoBar :: !InfoBar + , menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo + , menuActions :: !( HashMap ActionName GIO.SimpleAction ) + , colours :: !Colours } data Variables = Variables { uniqueSupply :: !UniqueSupply - , recomputeStrokesTVar :: !( STM.TVar Bool ) - , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) - , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) - , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) - , brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) ) - , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) - , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) - , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) - , toolTVar :: !( STM.TVar Tool ) - , modeTVar :: !( STM.TVar Mode ) - , debugTVar :: !( STM.TVar Bool ) - , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) - , fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) - , showGuidesTVar :: !( STM.TVar Bool ) - , maxHistorySizeTVar :: !( STM.TVar Int ) - , fitParametersTVar :: !( STM.TVar FitParameters ) + , recomputeStrokesTVar :: !( STM.TVar Bool ) + , documentRenderTVar :: !( STM.TVar ( ( Int32, Int32 ) -> Cairo.Render () ) ) + , activeDocumentTVar :: !( STM.TVar ( Maybe Unique ) ) + , openDocumentsTVar :: !( STM.TVar ( Map Unique DocumentHistory ) ) + , brushesTVar :: !( STM.TVar ( HashMap Brush Unique ) ) + , mousePosTVar :: !( STM.TVar ( Maybe ( Point2D Double ) ) ) + , mouseHoldTVar :: !( STM.TVar ( Maybe HoldAction ) ) + , modifiersTVar :: !( STM.TVar ( Set Modifier ) ) + , toolTVar :: !( STM.TVar Tool ) + , modeTVar :: !( STM.TVar Mode ) + , debugTVar :: !( STM.TVar Bool ) + , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) + , fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) ) + , showGuidesTVar :: !( STM.TVar Bool ) + , maxHistorySizeTVar :: !( STM.TVar Int ) + , fitParametersTVar :: !( STM.TVar FitParameters ) } -------------------------------------------------------------------------------- @@ -113,19 +119,14 @@ data Modifier deriving stock ( Show, Eq, Ord ) modifierKey :: Word32 -> Maybe Modifier -modifierKey GDK.KEY_Control_L = Just ( Control L ) -modifierKey GDK.KEY_Control_R = Just ( Control R ) -modifierKey GDK.KEY_Shift_L = Just ( Shift L ) -modifierKey GDK.KEY_Shift_R = Just ( Shift R ) -modifierKey GDK.KEY_Alt_L = Just ( Alt L ) -modifierKey GDK.KEY_Alt_R = Just ( Alt R ) -modifierKey _ = Nothing - -modifierType :: Modifier -> GDK.ModifierType -modifierType ( Control _ ) = GDK.ModifierTypeControlMask -modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask -modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask - +modifierKey n = case fromIntegral n of + GDK.KEY_Control_L -> Just ( Control L ) + GDK.KEY_Control_R -> Just ( Control R ) + GDK.KEY_Shift_L -> Just ( Shift L ) + GDK.KEY_Shift_R -> Just ( Shift R ) + GDK.KEY_Alt_L -> Just ( Alt L ) + GDK.KEY_Alt_R -> Just ( Alt R ) + _ -> Nothing data GuideAction = CreateGuide !Ruler diff --git a/src/app/MetaBrush/Document/Update.hs b/src/app/MetaBrush/Document/Update.hs index 243420a..48e95c9 100644 --- a/src/app/MetaBrush/Document/Update.hs +++ b/src/app/MetaBrush/Document/Update.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -38,6 +39,9 @@ import qualified Data.Map.Strict as Map import Data.Generics.Product.Fields ( field' ) +-- gi-gio +import qualified GI.Gio as GIO + -- gi-gtk import qualified GI.Gtk as GTK @@ -65,22 +69,25 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe ( MaybeT(..) ) +-- unordered-containers +import qualified Data.HashMap.Lazy as HashMap + ( lookup ) + -- MetaBrush +import {-# SOURCE #-} MetaBrush.Action + ( ActionName(..) ) import MetaBrush.Context ( UIElements(..), Variables(..) ) import MetaBrush.Document ( Document(..), DocumentContent(..) ) import MetaBrush.Document.History - ( DocumentHistory(..) + ( DocumentHistory(..), atStart, atEnd , newFutureStep, affirmPresent - , atStart, atEnd ) import {-# SOURCE #-} MetaBrush.UI.FileBar - ( removeFileTab ) + ( FileBarTab(..), removeFileTab ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( updateInfoBar ) -import MetaBrush.UI.Menu - ( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Util @@ -145,7 +152,7 @@ instance DocumentModification DocModification where -- -- Does nothing if no document is currently active. modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () -modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f = do +modifyingCurrentDocument uiElts@( UIElements { menuActions } ) vars@( Variables {..} ) f = do mbAction <- STM.atomically . runMaybeT $ do unique <- MaybeT ( STM.readTVar activeDocumentTVar ) oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar ) @@ -185,25 +192,21 @@ modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f uiUpdateAction <- updateUIAction uiElts vars pure $ Ap do uiUpdateAction - GTK.widgetSetSensitive undoMenuItem True - GTK.widgetSetSensitive redoMenuItem False + for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True ) + for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) pure do forOf_ docFold modif \ mbNewDoc -> do case mbNewDoc of - CloseDocument -> removeFileTab vars ( documentUnique oldDoc ) + CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc ) _ -> pure () uiUpdateAction sequenceAOf_ actionFold modif sequenceA_ mbAction - where - undoMenuItem, redoMenuItem :: GTK.MenuItem - undoMenuItem = menuItem $ undo $ menuItemSubmenu $ edit menu - redoMenuItem = menuItem $ redo $ menuItemSubmenu $ edit menu updateUIAction :: UIElements -> Variables -> STM ( IO () ) -updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do +updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do mbDocHist <- activeDocument vars let mbDoc :: Maybe Document @@ -214,18 +217,18 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar pure ( (,) <$> mbActiveTab <*> mbDoc ) pure do - updateTitle window title mbTitleText + updateTitle window titleLabel mbTitleText updateInfoBar viewportDrawingArea infoBar vars mbDoc - for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do - GTK.buttonSetLabel activeTabLabel ( displayName activeDoc ) - GTK.widgetQueueDraw activeTab - STM.atomically ( STM.writeTVar recomputeStrokesTVar True ) - for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do - GTK.widgetQueueDraw drawingArea + for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do + GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc ) + GTK.widgetQueueDraw fileBarTab + GTK.widgetQueueDraw fileBarTabCloseArea + updateHistoryState uiElts mbDocHist + STM.atomically ( STM.writeTVar recomputeStrokesTVar True ) -updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO () -updateTitle window title mbTitleText = do - GTK.labelSetText title titleText +updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO () +updateTitle window titleLabel mbTitleText = do + GTK.labelSetText titleLabel titleText GTK.setWindowTitle window titleText where titleText :: Text @@ -241,18 +244,12 @@ updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO () updateHistoryState ( UIElements {..} ) mbHist = case mbHist of Nothing -> do - GTK.widgetSetSensitive undoMenuItem False - GTK.widgetSetSensitive redoMenuItem False + for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) + for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) Just hist -> do if atStart hist - then GTK.widgetSetSensitive undoMenuItem False - else GTK.widgetSetSensitive undoMenuItem True + then for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) + else for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True ) if atEnd hist - then GTK.widgetSetSensitive redoMenuItem False - else GTK.widgetSetSensitive redoMenuItem True - where - editMenu :: EditMenu Object - editMenu = menuItemSubmenu ( edit menu ) - undoMenuItem, redoMenuItem :: GTK.MenuItem - undoMenuItem = menuItem $ undo $ editMenu - redoMenuItem = menuItem $ redo $ editMenu + then for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False ) + else for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True ) diff --git a/src/app/MetaBrush/Event.hs b/src/app/MetaBrush/Event.hs index 0b8e797..d3840e4 100644 --- a/src/app/MetaBrush/Event.hs +++ b/src/app/MetaBrush/Event.hs @@ -12,6 +12,10 @@ import Control.Monad ( void ) import Data.Foldable ( for_ ) +import Data.Int + ( Int32 ) +import Data.Word + ( Word32 ) -- gi-gdk import qualified GI.Gdk as GDK @@ -19,6 +23,10 @@ import qualified GI.Gdk as GDK -- gi-gtk import qualified GI.Gtk as GTK +-- stm +import qualified Control.Concurrent.STM.TVar as STM + ( readTVarIO ) + -- MetaBrush import Math.Vector2D ( Point2D(..), Vector2D(..) ) @@ -32,7 +40,7 @@ import MetaBrush.Action import MetaBrush.Context ( UIElements(..), Variables(..) ) import MetaBrush.UI.Viewport - ( Viewport(..), Ruler(..) ) + ( Viewport(..), ViewportEventControllers(..), Ruler(..) ) -------------------------------------------------------------------------------- @@ -40,72 +48,74 @@ handleEvents :: UIElements -> Variables -> IO () handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do -- Mouse events - afterWidgetMouseEvent viewportDrawingArea ViewportOrigin - afterWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner ) - afterWidgetMouseEvent leftRulerDrawingArea ( RulerOrigin LeftRuler ) - afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler ) + afterWidgetMouseEvent viewportEventControllers ViewportOrigin + afterWidgetMouseEvent rulerCornerEventControllers ( RulerOrigin RulerCorner ) + afterWidgetMouseEvent leftRulerEventControllers ( RulerOrigin LeftRuler ) + afterWidgetMouseEvent topRulerEventControllers ( RulerOrigin TopRuler ) -- Keyboard events - void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) - void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) + void $ GTK.onEventControllerKeyKeyPressed windowKeys + ( handleKeyboardPressEvent elts vars ) + void $ GTK.onEventControllerKeyKeyReleased windowKeys + ( handleKeyboardReleaseEvent elts vars ) -- Window quit - void $ GTK.onWidgetDestroy window ( quitEverything window ) + void $ GTK.onApplicationQueryEnd application ( quitEverything application window ) where - afterWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO () - afterWidgetMouseEvent drawingArea eventOrigin = do - void $ GTK.afterWidgetMotionNotifyEvent drawingArea ( handleMotionEvent elts vars eventOrigin ) - void $ GTK.afterWidgetScrollEvent drawingArea ( handleScrollEvent elts vars eventOrigin ) - void $ GTK.afterWidgetButtonPressEvent drawingArea ( handleMouseButtonEvent elts vars eventOrigin ) - void $ GTK.afterWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin ) + afterWidgetMouseEvent :: ViewportEventControllers -> ActionOrigin -> IO () + afterWidgetMouseEvent ( ViewportEventControllers {..}) eventOrigin = do + void $ GTK.afterEventControllerMotionMotion viewportMotionController + ( handleMotionEvent elts vars eventOrigin ) + void $ GTK.afterEventControllerScrollScroll viewportScrollController + ( handleScrollEvent elts vars ) + void $ GTK.afterGestureClickPressed viewportClicksController + ( handleMouseButtonEvent elts vars eventOrigin viewportClicksController ) + void $ GTK.afterGestureClickReleased viewportClicksController + ( handleMouseButtonRelease elts vars eventOrigin viewportClicksController ) -------------------------------------------------------------------------------- -- Mouse events. -handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool -handleMotionEvent elts vars eventOrigin eventMotion = do - x <- GDK.getEventMotionX eventMotion - y <- GDK.getEventMotionY eventMotion +handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () ) +handleMotionEvent elts vars eventOrigin x y = do mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) handleAction elts vars ( MouseMove mousePos ) - pure True -handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool -handleScrollEvent elts vars eventOrigin scrollEvent = do - dx <- GDK.getEventScrollDeltaX scrollEvent - dy <- GDK.getEventScrollDeltaY scrollEvent - x <- GDK.getEventScrollX scrollEvent - y <- GDK.getEventScrollY scrollEvent - mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) - handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) ) +handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool ) +handleScrollEvent elts vars dx dy = do + mbMousePos <- STM.readTVarIO ( mousePosTVar vars ) + handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) ) pure False -handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool -handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do - ty <- GDK.getEventButtonType mouseClickEvent +handleMouseButtonEvent + :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick + -> ( Int32 -> Double -> Double -> IO () ) +handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars eventOrigin gestureClick nbClicks x y = do let mbClick :: Maybe MouseClickType - mbClick = case ty of - GDK.EventTypeButtonPress -> Just SingleClick - GDK.EventType2buttonPress -> Just DoubleClick - _ -> Nothing + mbClick + | nbClicks >= 2 + = Just DoubleClick + | nbClicks == 1 + = Just SingleClick + | otherwise + = Nothing for_ mbClick \ click -> do - button <- GDK.getEventButtonButton mouseClickEvent - x <- GDK.getEventButtonX mouseClickEvent - y <- GDK.getEventButtonY mouseClickEvent + _ <- GTK.widgetGrabFocus viewportDrawingArea + button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick + -- ^^^^^ use button number 1 if no button number is reported (button == 0) mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) handleAction elts vars ( MouseClick eventOrigin click button mousePos ) - pure False -handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool -handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do - button <- GDK.getEventButtonButton mouseReleaseEvent - x <- GDK.getEventButtonX mouseReleaseEvent - y <- GDK.getEventButtonY mouseReleaseEvent +handleMouseButtonRelease + :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick + -> ( Int32 -> Double -> Double -> IO () ) +handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do + button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick + -- ^^^^^ same as above mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) handleAction elts vars ( MouseRelease button mousePos ) - pure False adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double ) adjustMousePosition _ ViewportOrigin pt = pure pt @@ -125,14 +135,16 @@ adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) = -------------------------------------------------------------------------------- -- Keyboard events. -handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool -handleKeyboardPressEvent elts vars evt = do - keyCode <- GDK.getEventKeyKeyval evt - handleAction elts vars ( KeyboardPress keyCode ) +handleKeyboardPressEvent + :: UIElements -> Variables + -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO Bool ) +handleKeyboardPressEvent elts vars keyVal _ _ = do + handleAction elts vars ( KeyboardPress keyVal ) pure False -- allow the default handler to run -handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool -handleKeyboardReleaseEvent elts vars evt = do - keyCode <- GDK.getEventKeyKeyval evt - handleAction elts vars ( KeyboardRelease keyCode ) - pure False -- allow the default handler to run + +handleKeyboardReleaseEvent + :: UIElements -> Variables + -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO () ) +handleKeyboardReleaseEvent elts vars keyVal _ _ = + handleAction elts vars ( KeyboardRelease keyVal ) diff --git a/src/app/MetaBrush/UI/FileBar.hs b/src/app/MetaBrush/UI/FileBar.hs index a1413c1..e059df1 100644 --- a/src/app/MetaBrush/UI/FileBar.hs +++ b/src/app/MetaBrush/UI/FileBar.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeApplications #-} module MetaBrush.UI.FileBar - ( FileBar(..) + ( FileBar(..), FileBarTab(..) , createFileBar, newFileTab, removeFileTab , TabLocation(..) ) @@ -15,11 +15,9 @@ module MetaBrush.UI.FileBar -- base import Control.Monad - ( join, unless, void ) + ( join, void ) import Data.Foldable ( for_, sequenceA_ ) -import Data.Int - ( Int32 ) import Data.Traversable ( for ) @@ -31,13 +29,12 @@ import qualified Data.Map.Strict as Map import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) +-- gi-gio +import qualified GI.Gio as GIO + -- gi-gtk import qualified GI.Gtk as GTK --- haskell-gi-base -import qualified Data.GI.Base.GValue as GI -import qualified Data.GI.Base.GType as GI - -- stm import qualified Control.Concurrent.STM as STM ( atomically ) @@ -48,9 +45,13 @@ import qualified Control.Concurrent.STM.TVar as STM import Control.Monad.Trans.Reader ( runReaderT ) +-- unordered-containers +import Data.HashMap.Lazy + ( HashMap ) + -- MetaBrush -import MetaBrush.Action - ( SwitchTo(..), Close(..), handleAction ) +import {-# SOURCE #-} MetaBrush.Action + ( ActionName, SwitchFromTo(..), Close(..), handleAction ) import MetaBrush.Asset.CloseTabButton ( drawCloseTabButton ) import MetaBrush.Asset.Colours @@ -67,16 +68,12 @@ import MetaBrush.Document.Update ( updateUIAction ) import {-# SOURCE #-} MetaBrush.UI.InfoBar ( InfoBar ) -import {-# SOURCE #-} MetaBrush.UI.Menu - ( Menu, ResourceType(Object) ) import MetaBrush.UI.Viewport ( Viewport(..) ) import MetaBrush.Unique ( Unique, freshUnique, uniqueText ) import MetaBrush.Util - ( widgetAddClass, widgetAddClasses - , Exists(..) - ) + ( widgetAddClass, widgetAddClasses ) -------------------------------------------------------------------------------- @@ -84,7 +81,14 @@ data FileBar = FileBar { fileBarBox :: !GTK.Box , fileTabsBox :: !GTK.Box - , fileBarPhantomRadioButton :: !GTK.RadioButton + , fileBarPhantomToggleButton :: !GTK.ToggleButton + } + +data FileBarTab + = FileBarTab + { fileBarTab :: !GTK.Box + , fileBarTabButton :: !GTK.ToggleButton + , fileBarTabCloseArea :: !GTK.DrawingArea } data TabLocation @@ -93,14 +97,12 @@ data TabLocation deriving stock Show newFileTab - :: Bool - -> UIElements + :: UIElements -> Variables -> Maybe DocumentHistory -> TabLocation -> IO () newFileTab - initialStage uiElts@( UIElements { fileBar = FileBar {..}, .. } ) vars@( Variables {..} ) mbDocHist @@ -116,18 +118,19 @@ newFileTab pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) let - newUnique :: Unique - newUnique = documentUnique ( present newDocHist ) + thisTabDocUnique :: Unique + thisTabDocUnique = documentUnique ( present newDocHist ) + -- TODO: make the file tab an EditableLabel -- File tab elements. - pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist ) - GTK.toggleButtonSetMode pgButton False -- don't display radio indicator + pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist ) + GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton ) closeFileButton <- GTK.buttonNew closeFileArea <- GTK.drawingAreaNew - GTK.containerAdd closeFileButton closeFileArea + GTK.buttonSetChild closeFileButton ( Just closeFileArea ) - void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do - mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar + GTK.drawingAreaSetDrawFunc closeFileArea $ Just \ _ cairoContext _ _ -> void do + mbTabDoc <- fmap present . Map.lookup thisTabDocUnique <$> STM.readTVarIO openDocumentsTVar let unsaved :: Bool unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc @@ -137,104 +140,115 @@ newFileTab -- Create box for file tab elements. tab <- GTK.boxNew GTK.OrientationHorizontal 0 widgetAddClasses tab [ "fileBarTab" ] - GTK.boxPackStart fileTabsBox tab False False 0 - GTK.boxPackStart tab pgButton True True 0 - GTK.boxPackStart tab closeFileButton False False 0 + GTK.boxAppend tab pgButton + GTK.boxAppend tab closeFileButton widgetAddClasses pgButton [ "fileBarTabButton" ] widgetAddClasses closeFileButton [ "fileBarCloseButton" ] - GTK.widgetShowAll tab - -- We've placed the new tab at the end. Now rearrange it if necessary. + -- Place the new tab in the correct position within the file bar. case newTabLoc of - LastTab -> pure () + LastTab -> + GTK.boxAppend fileTabsBox tab AfterCurrentTab -> do mbActiveTab <- fmap join $ STM.atomically do mbUnique <- STM.readTVar activeDocumentTVar for mbUnique \ docUnique -> do Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar - for_ mbActiveTab \ ( activeTab, _ ) -> do - old_gValue <- GI.newGValue GI.gtypeInt - GTK.containerChildGetProperty fileTabsBox activeTab "position" old_gValue - new_gValue <- GI.toGValue @Int32 =<< ( +1 ) <$> GI.fromGValue @Int32 old_gValue - GTK.containerChildSetProperty fileTabsBox tab "position" new_gValue - - -- Ensure consistency of hover/selection state between the two elements in the tab. - for_ @_ @_ @_ @() [ Exists @GTK.IsWidget pgButton, Exists @GTK.IsWidget closeFileButton ] \ ( Exists button ) -> do - void $ GTK.onWidgetEnterNotifyEvent button \ _ -> do - flags <- GTK.widgetGetStateFlags tab - GTK.widgetSetStateFlags tab ( GTK.StateFlagsPrelight : flags ) True - pure False - void $ GTK.onWidgetLeaveNotifyEvent button \ _ -> do - flags <- GTK.widgetGetStateFlags tab - GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsPrelight ) flags ) True - pure False + case mbActiveTab of + Just ( FileBarTab { fileBarTab = activeTab } ) + -> GTK.boxInsertChildAfter fileTabsBox tab ( Just activeTab ) + _ -> GTK.boxAppend fileTabsBox tab + let + fileBarTab :: FileBarTab + fileBarTab = + FileBarTab + { fileBarTab = tab + , fileBarTabButton = pgButton + , fileBarTabCloseArea = closeFileArea + } -- Update the state: switch to this new document. uiUpdateAction <- STM.atomically do - STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDocHist ) - STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique ( tab, pgButton ) ) - -- don't update UI if we are just creating file tabs for the first time - -- (we don't have access to the full menu at that point, so this would otherwise loop) - if initialStage - then pure ( pure () ) - else do - STM.writeTVar activeDocumentTVar ( Just newUnique ) - updateUIAction uiElts vars + STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique newDocHist ) + STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab ) + STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique ) + updateUIAction uiElts vars uiUpdateAction - void $ GTK.onButtonClicked pgButton do - isActive <- GTK.toggleButtonGetActive pgButton - flags <- GTK.widgetGetStateFlags tab - if isActive + void $ GTK.afterToggleButtonToggled pgButton do + nowActive <- GTK.toggleButtonGetActive pgButton + flags <- GTK.widgetGetStateFlags tab + mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar + if nowActive then do - GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True - handleAction uiElts vars ( SwitchTo newUnique ) + -- If changing tabs, switch document. + -- This will untoggle the previously active tab + -- ('onToggleButtonToggled' will run this handler). + handleAction uiElts vars ( SwitchFromTo mbPrevActiveDocUnique thisTabDocUnique ) + GTK.widgetSetStateFlags tab + ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags ) + True else do - GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True - GTK.widgetQueueDraw closeFileArea + -- Otherwise, ensure the tab hasn't been toggled off on its own + -- (clicking on an already selected tab shouldn't do anything, not untoggle the tab). + mbNewActiveDocUnique <- STM.readTVarIO activeDocumentTVar + case mbNewActiveDocUnique of + -- Clicking on already selected document: don't allow the tab to be toggled off. + Just unique | unique == thisTabDocUnique + -> do + GTK.toggleButtonSetActive pgButton True + GTK.widgetSetStateFlags tab + ( GTK.StateFlagsActive : filter (/= GTK.StateFlagsActive) flags ) + True + -- Otherwise: leave it toggled off. + _ -> GTK.widgetSetStateFlags tab + ( filter (/= GTK.StateFlagsActive) flags ) + True + + GTK.toggleButtonSetActive pgButton False + GTK.toggleButtonSetActive pgButton True void $ GTK.onButtonClicked closeFileButton do GTK.widgetQueueDraw closeFileArea - handleAction uiElts vars ( CloseThis newUnique ) - - -- Activate the button, unless we are creating buttons for the first time, - -- in which case we shouldn't activate it as we don't have a menu yet, - -- so we wouldn't be able to handle the associated action. - unless initialStage ( GTK.toggleButtonSetActive pgButton True ) + handleAction uiElts vars ( CloseThis thisTabDocUnique ) -- | Create a file bar: tabs allowing selection of the active document. -- -- Updates the active document when buttons are clicked. createFileBar :: Colours -> Variables - -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object + -> GTK.Application -> GTK.ApplicationWindow -> GTK.EventControllerKey + -> GTK.HeaderBar -> GTK.Label -> Viewport -> InfoBar + -> GTK.PopoverMenuBar -> HashMap ActionName GIO.SimpleAction -> IO FileBar createFileBar colours vars@( Variables { openDocumentsTVar } ) - window titleBar title viewport infoBar menu + application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions = do -- Create file bar: box containing scrollable tabs, and a "+" button after it. fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0 widgetAddClass fileBarBox "fileBar" - fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment ) + fileTabsScroll <- GTK.scrolledWindowNew GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True + GTK.widgetSetHexpand fileTabsScroll True newFileButton <- GTK.buttonNewWithLabel "+" widgetAddClasses newFileButton [ "newFileButton" ] - GTK.boxPackEnd fileBarBox newFileButton False False 0 - GTK.boxPackStart fileBarBox fileTabsScroll True True 0 + GTK.boxAppend fileBarBox fileTabsScroll + GTK.boxAppend fileBarBox newFileButton + GTK.widgetSetHalign newFileButton GTK.AlignEnd fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0 - GTK.containerAdd fileTabsScroll fileTabsBox + GTK.scrolledWindowSetChild fileTabsScroll ( Just fileTabsBox ) widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ] - -- Phantom radio button for when no page is selected (e.g. no documents opened yet). - fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) + -- Phantom toggle button for when no page is selected (e.g. no documents opened yet). + fileBarPhantomToggleButton <- GTK.toggleButtonNew let fileBar :: FileBar @@ -244,13 +258,13 @@ createFileBar documents <- STM.readTVarIO openDocumentsTVar for_ documents \ doc -> - newFileTab True + newFileTab uiElements vars ( Just doc ) LastTab void $ GTK.onButtonClicked newFileButton do - newFileTab False + newFileTab uiElements vars Nothing LastTab @@ -258,15 +272,18 @@ createFileBar pure fileBar -- | Close a document: remove the corresponding file tab from the file bar. -removeFileTab :: Variables -> Unique -> IO () -removeFileTab ( Variables {..} ) docUnique = do +removeFileTab :: UIElements -> Variables -> Unique -> IO () +removeFileTab + ( UIElements { fileBar = FileBar { fileTabsBox } } ) + ( Variables {..} ) + docUnique = do - cleanupAction <- STM.atomically do - -- Remove the tab. - mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar - for mbTab \ ( tab, _ ) -> do - STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique ) - STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique ) - pure ( GTK.widgetDestroy tab ) - - sequenceA_ cleanupAction + cleanupAction <- STM.atomically do + -- Remove the tab. + mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar + for mbTab \ ( FileBarTab { fileBarTab = tab } ) -> do + STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique ) + STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique ) + pure ( GTK.boxRemove fileTabsBox tab ) + + sequenceA_ cleanupAction diff --git a/src/app/MetaBrush/UI/FileBar.hs-boot b/src/app/MetaBrush/UI/FileBar.hs-boot index f324080..c2c029e 100644 --- a/src/app/MetaBrush/UI/FileBar.hs-boot +++ b/src/app/MetaBrush/UI/FileBar.hs-boot @@ -1,9 +1,6 @@ -{-# LANGUAGE DataKinds #-} - module MetaBrush.UI.FileBar - ( FileBar(..) - , createFileBar, newFileTab, removeFileTab - , TabLocation(..) + ( FileBar(..), FileBarTab(..), TabLocation(..) + , removeFileTab ) where @@ -11,18 +8,8 @@ module MetaBrush.UI.FileBar import qualified GI.Gtk as GTK -- MetaBrush -import MetaBrush.Asset.Colours - ( Colours ) import {-# SOURCE #-} MetaBrush.Context ( Variables, UIElements ) -import MetaBrush.Document.History - ( DocumentHistory ) -import {-# SOURCE #-} MetaBrush.UI.InfoBar - ( InfoBar ) -import {-# SOURCE #-} MetaBrush.UI.Menu - ( Menu, ResourceType(Object) ) -import MetaBrush.UI.Viewport - ( Viewport ) import MetaBrush.Unique ( Unique ) @@ -32,7 +19,14 @@ data FileBar = FileBar { fileBarBox :: !GTK.Box , fileTabsBox :: !GTK.Box - , fileBarPhantomRadioButton :: !GTK.RadioButton + , fileBarPhantomToggleButton :: !GTK.ToggleButton + } + +data FileBarTab + = FileBarTab + { fileBarTab :: !GTK.Box + , fileBarTabButton :: !GTK.ToggleButton + , fileBarTabCloseArea :: !GTK.DrawingArea } data TabLocation @@ -41,15 +35,4 @@ data TabLocation instance Show TabLocation -createFileBar - :: Colours -> Variables - -> GTK.Window -> GTK.Box -> GTK.Label -> Viewport -> InfoBar -> Menu Object - -> IO FileBar - -newFileTab - :: Bool - -> UIElements -> Variables - -> Maybe DocumentHistory -> TabLocation - -> IO () - -removeFileTab :: Variables -> Unique -> IO () +removeFileTab :: UIElements -> Variables -> Unique -> IO () diff --git a/src/app/MetaBrush/UI/InfoBar.hs b/src/app/MetaBrush/UI/InfoBar.hs index 30b030b..25e56e9 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs +++ b/src/app/MetaBrush/UI/InfoBar.hs @@ -78,6 +78,7 @@ createInfoBar :: Colours -> IO InfoBar createInfoBar colours = do infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0 widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ] + GTK.widgetSetHalign infoBarArea GTK.AlignEnd zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0 cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 @@ -85,7 +86,7 @@ createInfoBar colours = do botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do - GTK.boxPackEnd infoBarArea box False False 0 + GTK.boxPrepend infoBarArea box widgetAddClass box "infoBarBox" ------------- @@ -94,11 +95,11 @@ createInfoBar colours = do magnifierArea <- GTK.drawingAreaNew zoomText <- GTK.labelNew ( Just na ) - GTK.boxPackStart zoomBox magnifierArea True True 0 - GTK.boxPackStart zoomBox zoomText True True 0 + GTK.boxAppend zoomBox magnifierArea + GTK.boxAppend zoomBox zoomText - void $ GTK.onWidgetDraw magnifierArea \ ctx -> - ( `Cairo.renderWithContext` ctx ) $ do + GTK.drawingAreaSetDrawFunc magnifierArea $ Just \ _ cairoContext _ _ -> + void $ ( `Cairo.renderWithContext` cairoContext ) do Cairo.scale 0.9 0.9 Cairo.translate 14 10 drawMagnifier colours @@ -109,11 +110,11 @@ createInfoBar colours = do cursorPosArea <- GTK.drawingAreaNew cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) - GTK.boxPackStart cursorPosBox cursorPosArea False False 0 - GTK.boxPackStart cursorPosBox cursorPosText False False 0 + GTK.boxAppend cursorPosBox cursorPosArea + GTK.boxAppend cursorPosBox cursorPosText - void $ GTK.onWidgetDraw cursorPosArea \ ctx -> - ( `Cairo.renderWithContext` ctx ) $ do + GTK.drawingAreaSetDrawFunc cursorPosArea $ Just \ _ cairoContext _ _ -> + void $ ( `Cairo.renderWithContext` cairoContext ) do Cairo.scale 0.75 0.75 Cairo.translate 9.5 7 drawCursorIcon colours @@ -124,12 +125,11 @@ createInfoBar colours = do topLeftPosArea <- GTK.drawingAreaNew topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) - GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0 - GTK.boxPackStart topLeftPosBox topLeftPosText False False 0 + GTK.boxAppend topLeftPosBox topLeftPosArea + GTK.boxAppend topLeftPosBox topLeftPosText - void $ GTK.onWidgetDraw topLeftPosArea - $ Cairo.renderWithContext - ( drawTopLeftCornerRect colours ) + GTK.drawingAreaSetDrawFunc topLeftPosArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawTopLeftCornerRect colours ) cairoContext ------------------------- -- Bottom right position @@ -137,11 +137,11 @@ createInfoBar colours = do botRightPosArea <- GTK.drawingAreaNew botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) - GTK.boxPackStart botRightPosBox botRightPosArea False False 0 - GTK.boxPackStart botRightPosBox botRightPosText False False 0 + GTK.boxAppend botRightPosBox botRightPosArea + GTK.boxAppend botRightPosBox botRightPosText - void $ GTK.onWidgetDraw botRightPosArea \ ctx -> - ( `Cairo.renderWithContext` ctx ) $ do + GTK.drawingAreaSetDrawFunc botRightPosArea $ Just \ _ cairoContext _ _ -> + void $ ( `Cairo.renderWithContext` cairoContext ) do Cairo.scale -1 -1 Cairo.translate -40 -40 drawTopLeftCornerRect colours @@ -195,4 +195,4 @@ fixed digitsBefore digitsAfter x = case second tail . break ( == '.' ) $ showFFl replicate ( digitsBefore - l ) ' ' <> as <> "." <> bs <> replicate ( digitsAfter - r ) '0' na :: IsString a => a -na = " n/a" \ No newline at end of file +na = " n/a" diff --git a/src/app/MetaBrush/UI/InfoBar.hs-boot b/src/app/MetaBrush/UI/InfoBar.hs-boot index 6b7e882..5faf452 100644 --- a/src/app/MetaBrush/UI/InfoBar.hs-boot +++ b/src/app/MetaBrush/UI/InfoBar.hs-boot @@ -1,5 +1,5 @@ module MetaBrush.UI.InfoBar - ( InfoBar(..), createInfoBar, updateInfoBar ) + ( InfoBar(..), updateInfoBar ) where -- gi-gtk @@ -22,6 +22,5 @@ data InfoBar , cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label } -createInfoBar :: Colours -> IO InfoBar - -updateInfoBar :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO () +updateInfoBar + :: GTK.DrawingArea -> InfoBar -> Variables -> Maybe Document -> IO () diff --git a/src/app/MetaBrush/UI/Menu.hs b/src/app/MetaBrush/UI/Menu.hs index d9bc9fd..fc60770 100644 --- a/src/app/MetaBrush/UI/Menu.hs +++ b/src/app/MetaBrush/UI/Menu.hs @@ -1,52 +1,29 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -module MetaBrush.UI.Menu - ( newMenuBar - , Menu(..) - , FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..) - , ResourceType(..) - , MenuItem(..) - , createMenuBar - ) - where +module MetaBrush.UI.Menu where -- base import Control.Monad - ( void, unless ) + ( void ) import Data.Foldable - ( for_ ) -import Data.Kind - ( Type ) -import Data.Word - ( Word32 ) -import GHC.Generics - ( Generic ) - --- generic-lens -import Data.Generics.Product.Constraints - ( HasConstraints(constraints) ) + ( for_, traverse_ ) -- gi-cairo-connector import qualified GI.Cairo.Render.Connector as Cairo ( renderWithContext ) --- gi-gdk -import qualified GI.Gdk as GDK +-- gi-gio +import qualified GI.Gio as GIO -- gi-gtk import qualified GI.Gtk as GTK @@ -54,22 +31,33 @@ import qualified GI.Gtk as GTK -- text import Data.Text ( Text ) +import qualified Data.Text as Text + ( unpack ) -- transformers import Control.Monad.IO.Class - ( MonadIO(liftIO) ) + ( MonadIO(..) ) + +-- unordered-containers +import Data.HashMap.Strict + ( HashMap ) +import qualified Data.HashMap.Strict as HashMap + ( lookup, traverseWithKey ) +import Data.HashSet + ( HashSet ) +import qualified Data.HashSet as HashSet + ( fromList, toMap ) -- MetaBrush -import {-# SOURCE #-} MetaBrush.Action +import MetaBrush.Action + hiding ( save, saveAs ) import MetaBrush.Context - ( UIElements(..), Variables(..) - , LR(..), Modifier(..), modifierType - ) + ( UIElements(..), Variables(..) ) import MetaBrush.Asset.Colours ( Colours ) import MetaBrush.Asset.WindowIcons ( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) -import {-# SOURCE #-} MetaBrush.UI.FileBar +import MetaBrush.UI.FileBar ( TabLocation(..) ) import MetaBrush.Util ( widgetAddClass, widgetAddClasses ) @@ -77,289 +65,226 @@ import MetaBrush.Util -------------------------------------------------------------------------------- -- Types for describing menu items. -data ResourceType - = Description - | Object +data MenuItem where + SubmenuDescription :: + { submenuLabel :: !( Maybe Text ) + , submenuItems :: ![ MenuItem ] + } -> MenuItem + MenuItemDescription :: HandleAction action => + { menuItemLabel :: !Text + , menuItemAction :: !( Maybe ActionName, action ) + , menuItemAccel :: !( Maybe Text ) + } -> MenuItem + Section :: + { sectionName :: !( Maybe Text ) + , sectionItems :: [ MenuItem ] + } -> MenuItem -data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType ) -data instance MenuItem action submenu Description - = MenuItemDescription - { menuItemLabel :: !Text - , menuItemClasses :: ![ Text ] - , menuItemAction :: !action - , menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) ) - , submenuDescription :: !( submenu Description ) - } -data instance MenuItem action submenu Object - = MenuItem - { menuItem :: !GTK.MenuItem - , menuItemSubmenu :: !( submenu Object ) - } +menuActionNames :: HashSet ActionName +menuActionNames = HashSet.fromList + -- file menu + [ WinAction "newFile" + , WinAction "openFile" + , WinAction "openFolder" + , WinAction "save" + , WinAction "saveAs" + , WinAction "closeActive" + , WinAction "quit" + -- edit menu + , WinAction "undo" + , WinAction "redo" + , WinAction "cut" + , WinAction "copy" + , WinAction "paste" + , WinAction "duplicate" + , WinAction "delete" + -- view menu + , WinAction "toggleGuides" + -- about menu + , AppAction "about" + ] -data family Separator ( r :: ResourceType ) -data instance Separator Description - = SeparatorDescription - { separatorClasses :: ![ Text ] } -data instance Separator Object - = Separator - { separatorItem :: !GTK.MenuItem } - -data NoSubresource ( k :: ResourceType ) = NoSubresource +createMenuActions :: IO ( HashMap ActionName GIO.SimpleAction ) +createMenuActions = + HashMap.traverseWithKey + ( \ actionName _ -> GIO.simpleActionNew ( actionSimpleName actionName ) Nothing ) + ( HashSet.toMap menuActionNames ) -------------------------------------------------------------------------------- -- Menu used in MetaBrush. --- Types. +menuDescription :: [ MenuItem ] +menuDescription = + [ SubmenuDescription ( Just "File" ) fileMenuDescription + , SubmenuDescription ( Just "Edit" ) editMenuDescription + , SubmenuDescription ( Just "View" ) viewMenuDescription + , SubmenuDescription ( Just "Help" ) helpMenuDescription + ] -data Menu ( rt :: ResourceType ) - = Menu - { file :: !( MenuItem () FileMenu rt ) - , edit :: !( MenuItem () EditMenu rt ) - , view :: !( MenuItem () ViewMenu rt ) - , help :: !( MenuItem () HelpMenu rt ) - } - deriving stock Generic +fileMenuDescription :: [ MenuItem ] +fileMenuDescription = + [ MenuItemDescription "New" ( Just $ WinAction "newFile" , ( NewFile AfterCurrentTab ) ) ( Just "n" ) + , MenuItemDescription "Open file" ( Just $ WinAction "openFile" , ( OpenFile AfterCurrentTab ) ) ( Just "o" ) + , MenuItemDescription "Open folder" ( Just $ WinAction "openFolder" , ( OpenFolder AfterCurrentTab ) ) ( Just "o" ) + , MenuItemDescription "Save" ( Just $ WinAction "save" , Save ) ( Just "s" ) + , MenuItemDescription "Save as" ( Just $ WinAction "saveAs" , SaveAs ) ( Just "s" ) + , MenuItemDescription "Close" ( Just $ WinAction "closeActive", CloseActive ) ( Just "w" ) + , MenuItemDescription "Quit" ( Just $ WinAction "quit" , Quit ) ( Just "q" ) + ] -data FileMenu ( rt :: ResourceType ) - = FileMenu - { new :: !( MenuItem NewFile NoSubresource rt ) - , openFile :: !( MenuItem OpenFile NoSubresource rt ) - , openFolder :: !( MenuItem OpenFolder 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 +editMenuDescription :: [ MenuItem ] +editMenuDescription = + [ Section Nothing + [ MenuItemDescription "Undo" ( Just $ WinAction "undo", Undo ) ( Just "z" ) + , MenuItemDescription "Redo" ( Just $ WinAction "redo", Redo ) ( Just "y" ) + ] + , Section Nothing + [ MenuItemDescription "Cut" ( Just $ WinAction "cut" , Cut ) ( Just "x" ) + , MenuItemDescription "Copy" ( Just $ WinAction "copy" , Copy ) ( Just "c" ) + , MenuItemDescription "Paste" ( Just $ WinAction "paste" , Paste ) ( Just "v" ) + , MenuItemDescription "Duplicate" ( Just $ WinAction "duplicate", Duplicate ) ( Just "d" ) + , MenuItemDescription "Delete" ( Just $ WinAction "delete" , Delete ) ( Just "Delete" ) + ] + , Section Nothing + [ MenuItemDescription "Preferences" ( Nothing, () ) ( Just "p" ) + ] + ] -data EditMenu ( rt :: ResourceType ) - = EditMenu - { 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 +viewMenuDescription :: [ MenuItem ] +viewMenuDescription = + [ Section Nothing + [ MenuItemDescription "Navigator" ( Nothing, () ) Nothing + , MenuItemDescription "History" ( Nothing, () ) ( Just "h" ) + ] + , Section Nothing + [ MenuItemDescription "Strokes" ( Nothing, () ) Nothing + , MenuItemDescription "Brushes" ( Nothing, () ) Nothing + , MenuItemDescription "Metaparameters" ( Nothing, () ) Nothing + ] + , Section Nothing + [ MenuItemDescription "Transform" ( Nothing, () ) Nothing + ] + , Section Nothing + [ MenuItemDescription "Toggle guides" ( Just $ WinAction "toggleGuides", ToggleGuides ) ( Just "g" ) + ] + ] -data ViewMenu ( rt :: ResourceType ) - = ViewMenu - { 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 ) - , viewSep3 :: !( Separator rt ) - , toggleGuides :: !( MenuItem ToggleGuides NoSubresource rt ) - } - deriving stock Generic - -data HelpMenu ( rt :: ResourceType ) - = HelpMenu - { about :: !( MenuItem About NoSubresource rt ) } - deriving stock Generic - --- Descriptions. - -menuDescription :: Menu Description -menuDescription - = Menu - { file = MenuItemDescription "File" [ "menuItem", "file" ] () Nothing fileMenuDescription - , edit = MenuItemDescription "Edit" [ "menuItem", "edit" ] () Nothing editMenuDescription - , view = MenuItemDescription "View" [ "menuItem", "view" ] () Nothing viewMenuDescription - , help = MenuItemDescription "Help" [ "menuItem", "help" ] () Nothing helpMenuDescription - } - -fileMenuDescription :: FileMenu Description -fileMenuDescription - = FileMenu - { new = MenuItemDescription "New" [ "submenuItem" ] ( NewFile AfterCurrentTab ) ( Just ( GDK.KEY_N, [ Control L ] ) ) NoSubresource - , openFile = MenuItemDescription "Open file" [ "submenuItem" ] ( OpenFile AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L ] ) ) NoSubresource - , openFolder = MenuItemDescription "Open folder" [ "submenuItem" ] ( OpenFolder AfterCurrentTab ) ( Just ( GDK.KEY_O, [ Control L, Shift 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" ] CloseActive ( 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" ] 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" ] 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" ] () ( Just ( GDK.KEY_P, [ Control L, Shift L ] ) ) NoSubresource - } - -viewMenuDescription :: ViewMenu Description -viewMenuDescription - = ViewMenu - { 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 NoSubresource - , brushes = MenuItemDescription "Brushes" [ "submenuItem" ] () Nothing NoSubresource - , metaparameters = MenuItemDescription "Metaparameters" [ "submenuItem" ] () Nothing NoSubresource - , viewSep2 = SeparatorDescription [ "submenuSeparator" ] - , transform = MenuItemDescription "Transform" [ "submenuItem" ] () Nothing NoSubresource - , viewSep3 = SeparatorDescription [ "submenuSeparator" ] - , toggleGuides = MenuItemDescription "Hide guides" [ "submenuItem" ] ToggleGuides ( Just ( GDK.KEY_G, [] ) ) NoSubresource - } - -helpMenuDescription :: HelpMenu Description -helpMenuDescription - = HelpMenu - { about = MenuItemDescription "About MetaBrush" [ "submenuItem" ] About ( Just ( GDK.KEY_question, [ Control L ] ) ) NoSubresource } +helpMenuDescription :: [ MenuItem ] +helpMenuDescription = + [ MenuItemDescription "About MetaBrush" ( Just $ AppAction "about", About ) ( Just "question" ) + ] -------------------------------------------------------------------------------- --- Creating a GTK menu bar from a menu description. +-- Creating a GTK popover menu bar from a menu description. -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 - 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 - void $ GTK.onMenuItemActivate menuItem - ( handleAction uiElts vars menuItemAction ) - pure menuItem - -class CreateMenuItem desc res | desc -> res, res -> desc where - 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 ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) ) - => CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object ) - where - 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 uiElts vars accelGroup ( GTK.menuShellAppend submenu ) ) - submenuDescription - GTK.menuItemSetSubmenu menuItem ( Just submenu ) - attachToParent menuItem - pure - MenuItem - { menuItem = menuItem - , menuItemSubmenu = submenuItems - } -instance CreateMenuItem ( Separator Description ) ( Separator Object ) where - createMenuItem _ _ _ attachToParent ( SeparatorDescription {..} ) = do - separator <- GTK.separatorMenuItemNew - unless ( null separatorClasses ) do - widgetAddClasses separator separatorClasses - sep <- liftIO ( GTK.unsafeCastTo GTK.MenuItem separator ) - attachToParent sep - pure ( Separator { separatorItem = sep } ) - -newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object ) -newMenuBar uiElts vars accelGroup = do - menuBar <- GTK.menuBarNew - menu <- - constraints @CreateMenuItem - ( createMenuItem uiElts vars accelGroup ( GTK.menuShellAppend menuBar ) ) - menuDescription - pure ( menuBar, menu ) +makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m () +makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case + SubmenuDescription + { submenuLabel + , submenuItems + } -> do + submenu <- GIO.menuNew + makeMenu uiElts vars submenu submenuItems + GIO.menuAppendSubmenu menu submenuLabel submenu + MenuItemDescription + { menuItemLabel + , menuItemAction = ( mbActionName, actionData ) + , menuItemAccel + } -> do + for_ mbActionName \ actionName -> do + let + simpleName :: Text + simpleName = actionSimpleName actionName + case HashMap.lookup actionName menuActions of + Nothing -> + error + ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <> + ": missing action " <> show actionName + ) + Just menuItemAction -> do + _ <- GIO.onSimpleActionActivate menuItemAction + ( \ _ -> handleAction uiElts vars actionData ) + GIO.actionMapAddAction window menuItemAction + for_ menuItemAccel \ accelText -> do + actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing + GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText] + menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName ) + GIO.menuAppendItem menu menuItem + Section + { sectionName + , sectionItems + } -> do + section <- GIO.menuNew + makeMenu uiElts vars section sectionItems + GIO.menuAppendSection menu sectionName section -------------------------------------------------------------------------------- -- Creating the menu bar from its declarative specification. --- | Add the menu bar to the given box (title bar box). -createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object ) -createMenuBar uiElts@( UIElements { window, titleBar } ) 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 +createMenu :: MonadIO m => UIElements -> Variables -> m GIO.Menu +createMenu uiElts vars = do + menu <- GIO.menuNew + makeMenu uiElts vars menu menuDescription + pure menu +-- | Add the menu bar to the given box (title bar box). +createMenuBar :: MonadIO m => UIElements -> Variables -> Colours -> m GTK.PopoverMenuBar +createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colours = do + --accelGroup <- GTK.accelGroupNew + --GTK.windowAddAccelGroup window accelGroup + menu <- createMenu uiElts vars + menuBar <- GTK.popoverMenuBarNewFromModel ( Just menu ) + widgetAddClasses menuBar [ "menu", "text", "plain" ] + GTK.headerBarPackStart titleBar menuBar + -- TODO: this is a bit of a workaround to add hover highlight to top-level menu items. -- Activating a menu somehow sets the "hover" setting, -- so instead we use the "selected" setting for actual hover highlighting. - topLevelMenuItems <- GTK.containerGetChildren menuBar - for_ topLevelMenuItems \ topLevelMenuItem -> do - void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do - flags <- GTK.widgetGetStateFlags topLevelMenuItem - GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True - pure False - void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do - flags <- GTK.widgetGetStateFlags topLevelMenuItem - GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True - pure False + -- GTK4 FIXME + --topLevelMenuItems <- GTK.containerGetChildren menuBar + --for_ topLevelMenuItems \ topLevelMenuItem -> do + -- void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do + -- flags <- GTK.widgetGetStateFlags topLevelMenuItem + -- GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True + -- pure False + -- void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do + -- flags <- GTK.widgetGetStateFlags topLevelMenuItem + -- GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True + -- pure False windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0 - widgetAddClasses windowIcons [ "windowIcon" ] - GTK.boxPackEnd titleBar windowIcons False False 0 + widgetAddClasses windowIcons [ "windowIcons" ] + GTK.headerBarPackEnd titleBar windowIcons - minimiseButton <- GTK.buttonNew - fullscreenButton <- GTK.buttonNew - closeButton <- GTK.buttonNew + minimiseButton <- GTK.buttonNew + maximiseButton <- GTK.buttonNew + closeButton <- GTK.buttonNew - GTK.boxPackStart windowIcons minimiseButton True True 0 - GTK.boxPackStart windowIcons fullscreenButton True True 0 - GTK.boxPackStart windowIcons closeButton True True 0 + GTK.boxAppend windowIcons minimiseButton + GTK.boxAppend windowIcons maximiseButton + GTK.boxAppend windowIcons closeButton - minimiseArea <- GTK.drawingAreaNew - fullscreenArea <- GTK.drawingAreaNew - closeArea <- GTK.drawingAreaNew + minimiseArea <- GTK.drawingAreaNew + maximiseArea <- GTK.drawingAreaNew + closeArea <- GTK.drawingAreaNew - GTK.containerAdd minimiseButton minimiseArea - GTK.containerAdd fullscreenButton fullscreenArea - GTK.containerAdd closeButton closeArea + GTK.buttonSetChild minimiseButton ( Just minimiseArea ) + GTK.buttonSetChild maximiseButton ( Just maximiseArea ) + GTK.buttonSetChild closeButton ( Just closeArea ) - void $ GTK.onWidgetDraw minimiseArea - $ Cairo.renderWithContext - ( drawMinimise colours ) + GTK.drawingAreaSetDrawFunc minimiseArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawMinimise colours ) cairoContext - void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do - Just gdkWindow <- GTK.widgetGetWindow window - windowState <- GDK.windowGetState gdkWindow - if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState - then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext - else Cairo.renderWithContext ( drawMaximise colours ) cairoContext + GTK.drawingAreaSetDrawFunc maximiseArea $ Just \ _ cairoContext _ _ -> do + isMaximised <- GTK.getWindowMaximized window + if isMaximised + then void $ Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext + else void $ Cairo.renderWithContext ( drawMaximise colours ) cairoContext - void $ GTK.onWidgetDraw closeArea - $ Cairo.renderWithContext - ( drawClose colours ) + GTK.drawingAreaSetDrawFunc closeArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawClose colours ) cairoContext - for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do + for_ [ minimiseButton, maximiseButton, closeButton ] \ button -> do widgetAddClass button "windowIcon" widgetAddClass closeButton "closeWindowIcon" @@ -367,18 +292,17 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do --------------------------------------------------------- -- Actions - _ <- GTK.onButtonClicked closeButton ( quitEverything window ) - _ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) - _ <- GTK.onButtonClicked fullscreenButton do - Just gdkWindow <- GTK.widgetGetWindow window - windowState <- GDK.windowGetState gdkWindow - if GDK.WindowStateFullscreen `elem` windowState - then GTK.windowUnfullscreen window - else - if GDK.WindowStateMaximized `elem` windowState - then GTK.windowUnmaximize window - else GTK.windowMaximize window + _ <- GTK.onButtonClicked closeButton ( quitEverything application window ) + _ <- GTK.onButtonClicked minimiseButton ( GTK.windowMinimize window ) + _ <- GTK.onButtonClicked maximiseButton do + isMaximised <- GTK.getWindowMaximized window + if isMaximised + then GTK.windowUnmaximize window + else GTK.windowMaximize window + GTK.widgetQueueDraw maximiseArea --------------------------------------------------------- - pure menu + GTK.applicationSetMenubar application ( Just menu ) + + pure menuBar diff --git a/src/app/MetaBrush/UI/Menu.hs-boot b/src/app/MetaBrush/UI/Menu.hs-boot deleted file mode 100644 index b633a34..0000000 --- a/src/app/MetaBrush/UI/Menu.hs-boot +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE TypeFamilies #-} - -module MetaBrush.UI.Menu - ( ResourceType(..), MenuItem - , Menu - , FileMenu, EditMenu, ViewMenu, HelpMenu - , newMenuBar, createMenuBar - ) where - --- base -import Data.Kind - ( Type ) - --- gi-gtk -import qualified GI.Gtk as GTK - --- transformers -import Control.Monad.IO.Class - ( MonadIO ) -import MetaBrush.Asset.Colours - ( Colours ) -import {-# SOURCE #-} MetaBrush.Context - ( UIElements, Variables ) - --------------------------------------------------------------------------------- - -data ResourceType - = Description - | Object - -data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType ) - -data Menu ( rt :: ResourceType ) -type role Menu nominal - -data FileMenu ( rt :: ResourceType ) -type role FileMenu nominal - -data EditMenu ( rt :: ResourceType ) -type role EditMenu nominal - -data ViewMenu ( rt :: ResourceType ) -type role ViewMenu nominal - -data HelpMenu ( rt :: ResourceType ) -type role HelpMenu nominal - -newMenuBar :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> m ( GTK.MenuBar, Menu Object ) - -createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object ) diff --git a/src/app/MetaBrush/UI/Panels.hs b/src/app/MetaBrush/UI/Panels.hs index 927fbc1..6507f9c 100644 --- a/src/app/MetaBrush/UI/Panels.hs +++ b/src/app/MetaBrush/UI/Panels.hs @@ -27,7 +27,8 @@ createPanelBar panelBox = do widgetAddClass panelBox "panels" pane1 <- GTK.panedNew GTK.OrientationVertical - GTK.boxPackStart panelBox pane1 True True 0 + GTK.widgetSetVexpand pane1 True + GTK.boxAppend panelBox pane1 panels1 <- GTK.notebookNew panels2 <- GTK.notebookNew @@ -35,8 +36,8 @@ createPanelBar panelBox = do GTK.notebookSetGroupName panels1 ( Just "Panel" ) GTK.notebookSetGroupName panels2 ( Just "Panel" ) - GTK.panedPack1 pane1 panels1 True True - GTK.panedPack2 pane1 panels2 True True + GTK.panedSetStartChild pane1 panels1 + GTK.panedSetEndChild pane1 panels2 strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 brushesPanel <- GTK.boxNew GTK.OrientationVertical 0 @@ -75,9 +76,9 @@ createPanelBar panelBox = do transformContent <- GTK.labelNew ( Just "Transform tab content..." ) historyContent <- GTK.labelNew ( Just "History tab content..." ) - GTK.boxPackStart strokesPanel strokesContent True True 0 - GTK.boxPackStart brushesPanel brushesContent True True 0 - GTK.boxPackStart transformPanel transformContent True True 0 - GTK.boxPackStart historyPanel historyContent True True 0 + GTK.boxAppend strokesPanel strokesContent + GTK.boxAppend brushesPanel brushesContent + GTK.boxAppend transformPanel transformContent + GTK.boxAppend historyPanel historyContent pure () diff --git a/src/app/MetaBrush/UI/ToolBar.hs b/src/app/MetaBrush/UI/ToolBar.hs index 2e5f2fd..9307368 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs +++ b/src/app/MetaBrush/UI/ToolBar.hs @@ -11,8 +11,10 @@ module MetaBrush.UI.ToolBar where -- base +import Control.Arrow + ( second ) import Control.Monad - ( void ) + ( void, when ) import Data.Foldable ( for_ ) @@ -56,8 +58,9 @@ data Mode data ToolBar = ToolBar - { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton - , debugTool :: !GTK.ToggleButton } + { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool + :: !GTK.ToggleButton + } createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar createToolBar ( Variables {..} ) colours toolBar = do @@ -67,30 +70,35 @@ createToolBar ( Variables {..} ) colours toolBar = do GTK.widgetSetValign toolBar GTK.AlignStart GTK.widgetSetVexpand toolBar True - selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) - penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) - - _ <- GTK.onButtonClicked selectionTool $ STM.atomically do - STM.writeTVar toolTVar Selection - _ <- GTK.onButtonClicked penTool $ STM.atomically do - STM.writeTVar toolTVar Pen + selectionTool <- GTK.toggleButtonNew + penTool <- GTK.toggleButtonNew + GTK.toggleButtonSetGroup penTool ( Just selectionTool ) + makeToggleGroup $ + fmap + ( second \ toolVal -> STM.atomically do + STM.writeTVar toolTVar toolVal + STM.writeTVar partialPathTVar Nothing + STM.writeTVar recomputeStrokesTVar True + ) + [ ( selectionTool, Selection ), ( penTool, Pen ) ] + GTK.toggleButtonSetActive selectionTool True toolSep1 <- GTK.boxNew GTK.OrientationVertical 0 - pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) - brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) - metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) - - _ <- GTK.onButtonClicked pathTool $ STM.atomically do - STM.writeTVar modeTVar PathMode - STM.writeTVar recomputeStrokesTVar True - _ <- GTK.onButtonClicked brushTool $ STM.atomically do - STM.writeTVar modeTVar BrushMode - STM.writeTVar recomputeStrokesTVar True - _ <- GTK.onButtonClicked metaTool $ STM.atomically do - STM.writeTVar modeTVar MetaMode - STM.writeTVar recomputeStrokesTVar True - + pathTool <- GTK.toggleButtonNew + brushTool <- GTK.toggleButtonNew + metaTool <- GTK.toggleButtonNew + GTK.toggleButtonSetGroup brushTool ( Just pathTool ) + GTK.toggleButtonSetGroup metaTool ( Just pathTool ) + makeToggleGroup $ + fmap + ( second \ modeVal -> STM.atomically do + STM.writeTVar modeTVar modeVal + STM.writeTVar partialPathTVar Nothing + STM.writeTVar recomputeStrokesTVar True + ) + [ ( pathTool, PathMode ), ( brushTool, BrushMode ), ( metaTool, MetaMode ) ] + GTK.toggleButtonSetActive pathTool True toolSep2 <- GTK.boxNew GTK.OrientationVertical 0 @@ -100,20 +108,22 @@ createToolBar ( Variables {..} ) colours toolBar = do clicked <- GTK.toggleButtonGetActive debugTool STM.atomically do STM.writeTVar debugTVar clicked + STM.writeTVar partialPathTVar Nothing STM.writeTVar recomputeStrokesTVar True - GTK.boxPackStart toolBar selectionTool True True 0 - GTK.boxPackStart toolBar penTool True True 0 - GTK.boxPackStart toolBar toolSep1 True True 0 - GTK.boxPackStart toolBar pathTool True True 0 - GTK.boxPackStart toolBar brushTool True True 0 - GTK.boxPackStart toolBar metaTool True True 0 - GTK.boxPackStart toolBar toolSep2 True True 0 - GTK.boxPackStart toolBar debugTool True True 0 + GTK.boxAppend toolBar selectionTool + GTK.boxAppend toolBar penTool + GTK.boxAppend toolBar toolSep1 + GTK.boxAppend toolBar pathTool + GTK.boxAppend toolBar brushTool + GTK.boxAppend toolBar metaTool + GTK.boxAppend toolBar toolSep2 + GTK.boxAppend toolBar debugTool - for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do - GTK.toggleButtonSetMode tool False -- don't display radio indicator + for_ [ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool ] \ tool -> do widgetAddClass tool "toolItem" + GTK.widgetSetFocusOnClick tool False + GTK.widgetSetFocusable tool False widgetAddClass debugTool "toolItem" @@ -134,35 +144,37 @@ createToolBar ( Variables {..} ) colours toolBar = do metaToolArea <- GTK.drawingAreaNew debugToolArea <- GTK.drawingAreaNew - GTK.containerAdd selectionTool selectionToolArea - GTK.containerAdd penTool penToolArea - GTK.containerAdd pathTool pathToolArea - GTK.containerAdd brushTool brushToolArea - GTK.containerAdd metaTool metaToolArea - GTK.containerAdd debugTool debugToolArea + GTK.buttonSetChild selectionTool ( Just selectionToolArea ) + GTK.buttonSetChild penTool ( Just penToolArea ) + GTK.buttonSetChild pathTool ( Just pathToolArea ) + GTK.buttonSetChild brushTool ( Just brushToolArea ) + GTK.buttonSetChild metaTool ( Just metaToolArea ) + GTK.buttonSetChild debugTool ( Just debugToolArea ) - void $ GTK.onWidgetDraw selectionToolArea - $ Cairo.renderWithContext - ( drawCursorIcon colours ) + GTK.drawingAreaSetDrawFunc selectionToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawCursorIcon colours ) cairoContext - void $ GTK.onWidgetDraw penToolArea - $ Cairo.renderWithContext - ( drawPen colours ) + GTK.drawingAreaSetDrawFunc penToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawPen colours ) cairoContext - void $ GTK.onWidgetDraw pathToolArea - $ Cairo.renderWithContext - ( drawPath colours ) + GTK.drawingAreaSetDrawFunc pathToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawPath colours ) cairoContext - void $ GTK.onWidgetDraw brushToolArea - $ Cairo.renderWithContext - ( drawBrush colours ) + GTK.drawingAreaSetDrawFunc brushToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawBrush colours ) cairoContext - void $ GTK.onWidgetDraw metaToolArea - $ Cairo.renderWithContext - ( drawMeta colours ) + GTK.drawingAreaSetDrawFunc metaToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawMeta colours ) cairoContext - void $ GTK.onWidgetDraw debugToolArea - $ Cairo.renderWithContext - ( drawBug colours ) + GTK.drawingAreaSetDrawFunc debugToolArea $ Just \ _ cairoContext _ _ -> + void $ Cairo.renderWithContext ( drawBug colours ) cairoContext pure ( ToolBar {..} ) + +makeToggleGroup :: [ ( GTK.ToggleButton, IO () ) ] -> IO () +makeToggleGroup buttons = + for_ buttons \ ( button, action ) -> + GTK.afterToggleButtonToggled button do + isActive <- GTK.toggleButtonGetActive button + GTK.widgetSetSensitive button ( not isActive ) + when isActive action diff --git a/src/app/MetaBrush/UI/ToolBar.hs-boot b/src/app/MetaBrush/UI/ToolBar.hs-boot index f1317fe..559c966 100644 --- a/src/app/MetaBrush/UI/ToolBar.hs-boot +++ b/src/app/MetaBrush/UI/ToolBar.hs-boot @@ -24,6 +24,6 @@ instance Show Mode data ToolBar = ToolBar - { selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton - , debugTool :: !GTK.ToggleButton + { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool + :: !GTK.ToggleButton } diff --git a/src/app/MetaBrush/UI/Viewport.hs b/src/app/MetaBrush/UI/Viewport.hs index 2638a07..22cebc3 100644 --- a/src/app/MetaBrush/UI/Viewport.hs +++ b/src/app/MetaBrush/UI/Viewport.hs @@ -4,7 +4,8 @@ {-# LANGUAGE RecordWildCards #-} module MetaBrush.UI.Viewport - ( Viewport(..), createViewport + ( Viewport(..), ViewportEventControllers(..) + , createViewport , Ruler(..) ) where @@ -13,9 +14,6 @@ module MetaBrush.UI.Viewport import Data.Foldable ( for_ ) --- gi-gdk -import qualified GI.Gdk as GDK - -- gi-gtk import qualified GI.Gtk as GTK @@ -25,6 +23,13 @@ import MetaBrush.Util -------------------------------------------------------------------------------- +data ViewportEventControllers + = ViewportEventControllers + { viewportMotionController :: !GTK.EventControllerMotion + , viewportScrollController :: !GTK.EventControllerScroll + , viewportClicksController :: !GTK.GestureClick + } + data Viewport = Viewport { viewportDrawingArea @@ -32,6 +37,11 @@ data Viewport , leftRulerDrawingArea , topRulerDrawingArea :: !GTK.DrawingArea + , viewportEventControllers + , rulerCornerEventControllers + , leftRulerEventControllers + , topRulerEventControllers + :: !ViewportEventControllers } createViewport :: GTK.Grid -> IO Viewport @@ -56,9 +66,9 @@ createViewport viewportGrid = do leftRuler <- GTK.boxNew GTK.OrientationVertical 0 topRuler <- GTK.boxNew GTK.OrientationHorizontal 0 - GTK.containerAdd rvRulerCorner rulerCorner - GTK.containerAdd rvLeftRuler leftRuler - GTK.containerAdd rvTopRuler topRuler + GTK.revealerSetChild rvRulerCorner ( Just rulerCorner ) + GTK.revealerSetChild rvLeftRuler ( Just leftRuler ) + GTK.revealerSetChild rvTopRuler ( Just topRuler ) widgetAddClasses rulerCorner [ "ruler", "rulerCorner" ] widgetAddClasses leftRuler [ "ruler", "leftRuler" ] @@ -73,13 +83,13 @@ createViewport viewportGrid = do GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp rulerCornerDrawingArea <- GTK.drawingAreaNew - GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0 + GTK.boxAppend rulerCorner rulerCornerDrawingArea leftRulerDrawingArea <- GTK.drawingAreaNew - GTK.boxPackStart leftRuler leftRulerDrawingArea True True 0 + GTK.boxAppend leftRuler leftRulerDrawingArea topRulerDrawingArea <- GTK.drawingAreaNew - GTK.boxPackStart topRuler topRulerDrawingArea True True 0 + GTK.boxAppend topRuler topRulerDrawingArea GTK.widgetSetHexpand rulerCorner False GTK.widgetSetVexpand rulerCorner False @@ -91,14 +101,49 @@ createViewport viewportGrid = do GTK.widgetSetVexpand viewportOverlay True viewportDrawingArea <- GTK.drawingAreaNew - GTK.setContainerChild viewportOverlay viewportDrawingArea + GTK.overlaySetChild viewportOverlay ( Just viewportDrawingArea ) - for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do - GTK.widgetAddEvents drawingArea - [ GDK.EventMaskPointerMotionMask - , GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask - , GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask - ] + -- Adding mouse event controllers to all drawing areas. + viewportMotion <- GTK.eventControllerMotionNew + viewportScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ] + viewportClicks <- GTK.gestureClickNew + GTK.gestureSingleSetButton viewportClicks 0 + let + viewportEventControllers :: ViewportEventControllers + viewportEventControllers = + ViewportEventControllers viewportMotion viewportScroll viewportClicks + + rulerCornerMotion <- GTK.eventControllerMotionNew + rulerCornerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ] + rulerCornerClicks <- GTK.gestureClickNew + GTK.gestureSingleSetButton rulerCornerClicks 0 + let + rulerCornerEventControllers :: ViewportEventControllers + rulerCornerEventControllers = + ViewportEventControllers rulerCornerMotion rulerCornerScroll rulerCornerClicks + + leftRulerMotion <- GTK.eventControllerMotionNew + leftRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ] + leftRulerClicks <- GTK.gestureClickNew + GTK.gestureSingleSetButton leftRulerClicks 0 + let + leftRulerEventControllers :: ViewportEventControllers + leftRulerEventControllers = + ViewportEventControllers leftRulerMotion leftRulerScroll leftRulerClicks + + topRulerMotion <- GTK.eventControllerMotionNew + topRulerScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ] + topRulerClicks <- GTK.gestureClickNew + GTK.gestureSingleSetButton topRulerClicks 0 + let + topRulerEventControllers :: ViewportEventControllers + topRulerEventControllers = + ViewportEventControllers topRulerMotion topRulerScroll topRulerClicks + + for_ [ viewportDrawingArea, rulerCornerDrawingArea, topRulerDrawingArea ] + ( `GTK.widgetSetHexpand` True ) + for_ [ viewportDrawingArea, rulerCornerDrawingArea, leftRulerDrawingArea ] + ( `GTK.widgetSetVexpand` True ) {- ----------------- diff --git a/src/app/MetaBrush/Util.hs b/src/app/MetaBrush/Util.hs index 9a91d71..198e161 100644 --- a/src/app/MetaBrush/Util.hs +++ b/src/app/MetaBrush/Util.hs @@ -43,10 +43,10 @@ import Control.Monad.Trans.Maybe withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b withRGBA rgba f = do - r <- GDK.getRGBARed rgba - g <- GDK.getRGBAGreen rgba - b <- GDK.getRGBABlue rgba - a <- GDK.getRGBAAlpha rgba + r <- realToFrac <$> GDK.getRGBARed rgba + g <- realToFrac <$> GDK.getRGBAGreen rgba + b <- realToFrac <$> GDK.getRGBABlue rgba + a <- realToFrac <$> GDK.getRGBAAlpha rgba f r g b a showRGBA :: MonadIO m => GDK.RGBA -> m String