hashirama/metabrush
1
0
Fork 0
mirror of https://gitlab.com/sheaf/metabrush.git synced 2024-11-05 23:03:38 +00:00
Code Issues Actions Projects Releases Wiki Activity

Adapt to the changes in GTK4

Browse source
This commit is contained in:
sheaf 2021-04-21 15:08:34 +00:00
parent a9adcba8eb 1b0382f3b0
commit 5717c80e93
22 changed files with 1500 additions and 1411 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
MetaBrush.cabal
View file

@ -10,7 +10,7 @@ data-dir:
assets assets
data-files: data-files:
theme.css theme.css
icon.png icons/*
description: description:
MetaBrush is a GUI for brush calligraphy based on Bézier curves. MetaBrush is a GUI for brush calligraphy based on Bézier curves.
@ -118,6 +118,7 @@ executable MetaBrush
other-modules: other-modules:
MetaBrush.Action MetaBrush.Action
, MetaBrush.Application
, MetaBrush.Asset.Brushes , MetaBrush.Asset.Brushes
, MetaBrush.Asset.CloseTabButton , MetaBrush.Asset.CloseTabButton
, MetaBrush.Asset.Colours , MetaBrush.Asset.Colours
@ -175,7 +176,7 @@ executable MetaBrush
, atomic-file-ops , atomic-file-ops
^>= 0.3.0.0 ^>= 0.3.0.0
, bytestring , bytestring
^>= 0.10.10.0 >= 0.10.10.0 && < 0.12
, directory , directory
>= 1.3.4.0 && < 1.4 >= 1.3.4.0 && < 1.4
, dlist , dlist
@ -191,7 +192,7 @@ executable MetaBrush
, gi-cairo-connector , gi-cairo-connector
^>= 0.1.0 ^>= 0.1.0
, gi-gdk , gi-gdk
>= 3.0.22 && < 3.1 >= 4.0.2 && < 4.1
, gi-gio , gi-gio
>= 2.0.27 && < 2.1 >= 2.0.27 && < 2.1
, gi-glib , gi-glib
@ -199,9 +200,9 @@ executable MetaBrush
, gi-gobject , gi-gobject
^>= 2.0.24 ^>= 2.0.24
, gi-gtk , gi-gtk
>= 3.0.35 && < 3.1 >= 4.0.3 && < 4.1
, gi-gtksource --, gi-gtksource
>= 3.0.23 && < 3.1 -- >= 3.0.23 && < 3.1
, hashable , hashable
^>= 1.3.0.0 ^>= 1.3.0.0
, haskell-gi , haskell-gi

462
app/Main.hs
View file

@ -1,15 +1,5 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NegativeLiterals #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Main module Main
( main ) ( main )
@ -17,149 +7,24 @@ module Main
-- base -- base
import Control.Monad import Control.Monad
( forever, void ) ( void )
import Control.Monad.ST
( stToIO )
import Data.Foldable
( for_ )
import Data.Function
( (&) )
import Data.Int
( Int32 )
import System.Exit import System.Exit
( exitSuccess ) ( ExitCode(..), exitSuccess, exitWith )
import GHC.Conc import GHC.Conc
( forkIO, getNumProcessors, setNumCapabilities ) ( getNumProcessors, setNumCapabilities )
-- containers -- gi-gio
import Data.Map.Strict import qualified GI.Gio as GIO
( 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 -- gi-gobject
import qualified System.Directory as Directory import qualified GI.GObject as GObject
( 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-gtk -- gi-gtk
import qualified GI.Gtk as 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 -- MetaBrush
import Math.Bezier.Cubic.Fit import MetaBrush.Application
( FitParameters(..) ) ( runApplication )
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 )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -179,305 +44,14 @@ main = do
setNumCapabilities caps 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 case exitCode of
circleBrushUnique <- runReaderT freshUnique uniqueSupply 0 -> exitSuccess
docUnique <- runReaderT freshUnique uniqueSupply _ -> exitWith ( ExitFailure $ fromIntegral exitCode )
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

95
assets/theme.css
View file

@ -1,13 +1,17 @@
* {
.metabrush * {
all: unset; all: unset;
} }
/* Colors parsed by application */ /* Colors parsed by application */
.bg { .bg {
background-color: rgb(41, 40, 40); background-color: rgb(41, 40, 40);
color: rgb(41, 40, 40);
} }
.active { .active {
background-color: rgb(72,70,61); background-color: rgb(72,70,61);
color: rgb(72,70,61);
} }
.close { .close {
color: rgb(181,43,43); color: rgb(181,43,43);
@ -65,21 +69,24 @@
} }
.viewport { .viewport {
background-color: rgb(236, 223, 210); background-color: rgb(236, 223, 210);
-GtkWidget-window-dragging: false; color: rgb(236, 223, 210);
min-width: 120px; min-width: 120px;
min-height: 90px; min-height: 90px;
} }
.viewportScrollbar { .viewportScrollbar {
background-color: rgba(45, 39, 39, 0.66); background-color: rgba(45, 39, 39, 0.66);
color: rgba(45, 39, 39, 0.66);
margin: 4px; margin: 4px;
min-width: 8px; min-width: 8px;
min-height: 8px; min-height: 8px;
} }
.tabScrollbar { .tabScrollbar {
background-color: rgba(48, 45, 38, 0.66); background-color: rgba(48, 45, 38, 0.66);
color: rgba(48, 45, 38, 0.66);
} }
.ruler { .ruler {
background-color: rgb(237, 226, 154); background-color: rgb(237, 226, 154);
color: rgb(237, 226, 154);
min-width: 16px; min-width: 16px;
min-height: 16px; min-height: 16px;
background-size: 16px 16px; background-size: 16px 16px;
@ -97,7 +104,7 @@
color: rgba(156, 231, 255, 0.5); color: rgba(156, 231, 255, 0.5);
} }
.selected { .selected {
color: rgba(161,201,236,0.5) color: rgba(161,201,236,0.5);
} }
.selectedOutline { .selectedOutline {
color: rgb(74,150,218); color: rgb(74,150,218);
@ -113,10 +120,17 @@ tooltip {
border: 1px solid rgb(28,25,25); border: 1px solid rgb(28,25,25);
} }
.window, .dialog { .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 colour */
/* Basic text font */ /* Basic text font */
@ -193,6 +207,7 @@ tooltip {
.titleBar { .titleBar {
min-height: 24px; min-height: 24px;
font-size: 12px; font-size: 12px;
background-color: rgb(41, 40, 40);
} }
/* /*
@ -228,66 +243,65 @@ tooltip {
background-color: #eadfcc; background-color: #eadfcc;
} }
/* Menu bar */
.menuBar { .menu label {
padding-left: 4px; color:rgb(212, 190, 152);
} }
.menuItem { .menu :disabled {
color: rgba(212, 190, 152,0.5); color:rgb(149,149,149);
background-color: rgb(41, 40, 40); }
.menu item {
padding-left: 8px; padding-left: 8px;
padding-right: 8px; padding-right: 8px;
margin-left: 0px; color: rgb(212, 190, 152);
border-top: 2px solid rgb(41, 40, 40); border-top: 2px solid rgb(41, 40, 40);
} }
/* Menu item hover effect (workaround) */ .menu :hover {
.menuItem:selected { color: rgb(212, 190, 152);
border-color: rgb(72,70,61); border-color: rgb(72,70,61);
color: rgb(212, 190, 152);
} }
/* Styling for active menu item */ .menu item > * :hover {
.menuItem:active, .menuItem:checked, .menuItem:hover { border-color: rgb(212, 190, 152);
border-color: rgb(234,223,204);
background-color: rgb(72,70,61); background-color: rgb(72,70,61);
color: rgb(212, 190, 152);
} }
.menuItem > * > * { /* Top-level menu items */
box-shadow: 2px 4px 3px -1px rgba(28,25,25,0.5);
border: 1px solid rgb(28,25,25); /* TODO: shadows not working properly */
border-top: 1px solid rgb(72,70,61); .menu item > popover > contents > stack > box > box {
color: rgb(212, 190, 152); box-shadow: 0 0 1px 2px rgba(0,0,0,0.5);
} }
.submenuItem { /* Submenus without separators */
color: rgb(212, 190, 152); .menu item > popover > contents > stack > box > box > modelbutton {
padding-top: 4px;
padding-bottom: 4px;
padding-left: 10px;
padding-right: 10px;
background-color: rgb(41, 40, 40); background-color: rgb(41, 40, 40);
color: rgb(72,70,61);
border-top: 0px;
border-left: 2px solid rgb(41, 40, 40); 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); 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 { .accelLabel {
padding: 2px 8px 2px 0px; padding: 2px 8px 2px 0px;
@ -441,7 +455,6 @@ tooltip {
.infoBar { .infoBar {
min-height: 40px; min-height: 40px;
font-size: 10px; font-size: 10px;
-GtkWidget-window-dragging: true;
} }
.infoBarInfo { .infoBarInfo {

12
cabal.project
View file

@ -30,18 +30,6 @@ source-repository-package
location: https://github.com/sheaf/generic-lens location: https://github.com/sheaf/generic-lens
tag: 8d3f0b405894ecade5821c99dcde6efb4a637363 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 -- superrecord API improvements
source-repository-package source-repository-package
type: git type: git

228
src/app/MetaBrush/Action.hs
View file

@ -1,8 +1,11 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -24,11 +27,13 @@ import Data.Foldable
import Data.Int import Data.Int
( Int32 ) ( Int32 )
import Data.Maybe import Data.Maybe
( listToMaybe ) ( catMaybes, fromMaybe )
import Data.Traversable import Data.Traversable
( for ) ( for )
import Data.Word import Data.Word
( Word32 ) ( Word32 )
import GHC.Generics
( Generic )
-- acts -- acts
import Data.Act import Data.Act
@ -59,9 +64,22 @@ import Data.Generics.Product.Fields
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as 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 -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- haskell-gi-base
import qualified Data.GI.Base as GI
-- hashable
import Data.Hashable
( Hashable )
-- lens -- lens
import Control.Lens import Control.Lens
( over, set ) ( over, set )
@ -129,9 +147,7 @@ import MetaBrush.UI.Coordinates
import MetaBrush.UI.InfoBar import MetaBrush.UI.InfoBar
( updateInfoBar ) ( updateInfoBar )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
( TabLocation(..), newFileTab, removeFileTab ) ( FileBarTab(..), TabLocation(..), newFileTab, removeFileTab )
import MetaBrush.UI.Menu
( MenuItem(..), Menu(..), ViewMenu(..) )
import MetaBrush.UI.ToolBar import MetaBrush.UI.ToolBar
( Tool(..), Mode(..) ) ( Tool(..), Mode(..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
@ -139,10 +155,22 @@ import MetaBrush.UI.Viewport
import MetaBrush.Unique import MetaBrush.Unique
( Unique ) ( Unique )
import MetaBrush.Util 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 class HandleAction action where
handleAction :: UIElements -> Variables -> action -> IO () handleAction :: UIElements -> Variables -> action -> IO ()
@ -161,7 +189,7 @@ data NewFile = NewFile TabLocation
instance HandleAction NewFile where instance HandleAction NewFile where
handleAction uiElts vars ( NewFile tabLoc ) = handleAction uiElts vars ( NewFile tabLoc ) =
newFileTab False uiElts vars Nothing tabLoc newFileTab uiElts vars Nothing tabLoc
--------------- ---------------
-- Open file -- -- Open file --
@ -178,14 +206,22 @@ instance HandleAction OpenFile where
( Just "Open" ) ( Just "Open" )
( Just "Cancel" ) ( Just "Cancel" )
GTK.fileChooserSetSelectMultiple fileChooser True GTK.fileChooserSetSelectMultiple fileChooser True
GTK.fileChooserSetAction fileChooser GTK.FileChooserActionOpen
GTK.nativeDialogSetModal fileChooser True GTK.nativeDialogSetModal fileChooser True
fileFilter <- GTK.fileFilterNew fileFilter <- GTK.fileFilterNew
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" ) GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
GTK.fileFilterAddPattern fileFilter "*.mb" GTK.fileFilterAddPattern fileFilter "*.mb"
GTK.fileChooserAddFilter fileChooser fileFilter GTK.fileChooserAddFilter fileChooser fileFilter
void $ GTK.nativeDialogRun fileChooser GTK.nativeDialogShow fileChooser
filePaths <- GTK.fileChooserGetFilenames fileChooser void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
for_ filePaths \ filePath -> 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 knownBrushes <- STM.atomically $ STM.readTVar brushesTVar
( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath ( mbDoc, knownBrushes' ) <- loadDocument uniqueSupply knownBrushes filePath
STM.atomically ( STM.writeTVar brushesTVar knownBrushes' ) STM.atomically ( STM.writeTVar brushesTVar knownBrushes' )
@ -195,24 +231,28 @@ instance HandleAction OpenFile where
let let
newDocHist :: DocumentHistory newDocHist :: DocumentHistory
newDocHist = newHistory doc newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc newFileTab uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist ) 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 warningDialog window filePath errMess = do
dialog <- GTK.new GTK.MessageDialog [] dialog <- GTK.new GTK.MessageDialog []
GTK.setMessageDialogText dialog GTK.setMessageDialogText dialog
( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) ) ( "Could not load file at " <> Text.pack filePath <> ":\n" <> Text.pack ( show errMess ) )
GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning GTK.setMessageDialogMessageType dialog GTK.MessageTypeWarning
GTK.setWindowResizable dialog False GTK.setWindowResizable dialog True
GTK.setWindowDecorated dialog False GTK.setWindowDecorated dialog False
GTK.windowSetTransientFor dialog ( Just window ) GTK.windowSetTransientFor dialog ( Just window )
GTK.windowSetModal dialog True GTK.windowSetModal dialog True
widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ] widgetAddClasses dialog [ "bg", "plain", "text", "dialog" ]
closeButton <- GTK.dialogAddButton dialog "OK" 1 closeButton <- GTK.dialogAddButton dialog "OK" 1
widgetAddClass closeButton "dialogButton" widgetAddClass closeButton "dialogButton"
_ <- GTK.dialogRun dialog GTK.widgetShow dialog
GTK.widgetDestroy dialog void $ GTK.afterDialogResponse dialog \ _ -> do
GTK.windowDestroy dialog
----------------- -----------------
-- Open folder -- -- Open folder --
@ -228,11 +268,14 @@ instance HandleAction OpenFolder where
GTK.FileChooserActionSelectFolder GTK.FileChooserActionSelectFolder
( Just "Select Folder" ) ( Just "Select Folder" )
( Just "Cancel" ) ( Just "Cancel" )
GTK.fileChooserSetSelectMultiple fileChooser True GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSelectFolder
GTK.nativeDialogSetModal fileChooser True GTK.nativeDialogSetModal fileChooser True
void $ GTK.nativeDialogRun fileChooser GTK.nativeDialogShow fileChooser
folderPaths <- GTK.fileChooserGetFilenames fileChooser void $ GTK.afterNativeDialogResponse fileChooser \ response -> do
for_ folderPaths \ folderPath -> do when ( response == fromIntegral ( fromEnum GTK.ResponseTypeAccept ) ) do
folder <- GTK.fileChooserGetFile fileChooser
mbFolderPath <- GIO.fileGetPath folder
for_ mbFolderPath \ folderPath -> do
exists <- doesDirectoryExist folderPath exists <- doesDirectoryExist folderPath
when exists do when exists do
filePaths <- listDirectory folderPath filePaths <- listDirectory folderPath
@ -246,12 +289,13 @@ instance HandleAction OpenFolder where
let let
newDocHist :: DocumentHistory newDocHist :: DocumentHistory
newDocHist = newHistory doc newDocHist = newHistory doc
newFileTab False uiElts vars ( Just newDocHist ) tabLoc newFileTab uiElts vars ( Just newDocHist ) tabLoc
updateHistoryState uiElts ( Just newDocHist ) updateHistoryState uiElts ( Just newDocHist )
GObject.objectUnref folder
--------------- --------------------
-- Save file -- -- Save & Save as --
--------------- --------------------
data Save = Save data Save = Save
deriving stock Show deriving stock Show
@ -260,6 +304,12 @@ instance HandleAction Save where
handleAction uiElts vars _ = handleAction uiElts vars _ =
save uiElts vars True 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 :: UIElements -> Variables -> Bool -> IO ()
save uiElts vars keepOpen = do save uiElts vars keepOpen = do
mbDoc <- fmap present <$> STM.atomically ( activeDocument vars ) mbDoc <- fmap present <$> STM.atomically ( activeDocument vars )
@ -276,41 +326,35 @@ save uiElts vars keepOpen = do
modif = if keepOpen then SaveDocument Nothing else CloseDocument modif = if keepOpen then SaveDocument Nothing else CloseDocument
pure $ UpdateDocAndThen modif ( saveDocument filePath doc ) 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 :: UIElements -> Variables -> Bool -> IO ()
saveAs uiElts vars keepOpen = do saveAs uiElts vars keepOpen =
mbSavePath <- askForSavePath uiElts withSavePath uiElts \ savePath ->
for_ mbSavePath \ savePath ->
modifyingCurrentDocument uiElts vars \ doc -> do modifyingCurrentDocument uiElts vars \ doc -> do
let let
modif :: DocumentUpdate modif :: DocumentUpdate
modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument modif = if keepOpen then SaveDocument ( Just savePath ) else CloseDocument
pure $ UpdateDocAndThen modif ( saveDocument savePath doc ) pure $ UpdateDocAndThen modif ( saveDocument savePath doc )
askForSavePath :: UIElements -> IO ( Maybe FilePath ) withSavePath :: UIElements -> ( FilePath -> IO () ) -> IO ()
askForSavePath ( UIElements {..} ) = do withSavePath ( UIElements {..} ) action = do
fileChooser <- fileChooser <-
GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window ) GTK.fileChooserNativeNew ( Just "Save MetaBrush document..." ) ( Just window )
GTK.FileChooserActionSave GTK.FileChooserActionSave
( Just "Save" ) ( Just "Save" )
( Just "Cancel" ) ( Just "Cancel" )
GTK.nativeDialogSetModal fileChooser True GTK.nativeDialogSetModal fileChooser True
GTK.fileChooserSetDoOverwriteConfirmation fileChooser True GTK.fileChooserSetAction fileChooser GTK.FileChooserActionSave
fileFilter <- GTK.fileFilterNew fileFilter <- GTK.fileFilterNew
GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" ) GTK.fileFilterSetName fileFilter ( Just "MetaBrush document" )
GTK.fileFilterAddPattern fileFilter "*.mb" GTK.fileFilterAddPattern fileFilter "*.mb"
GTK.fileChooserAddFilter fileChooser fileFilter GTK.fileChooserAddFilter fileChooser fileFilter
void $ GTK.nativeDialogRun fileChooser GTK.nativeDialogShow fileChooser
fmap fullFilePath . listToMaybe <$> GTK.fileChooserGetFilenames 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 where
fullFilePath :: FilePath -> FilePath fullFilePath :: FilePath -> FilePath
fullFilePath fp fullFilePath fp
@ -326,7 +370,7 @@ askForSavePath ( UIElements {..} ) = do
data Close data Close
= CloseActive -- ^ Close active document. = CloseActive -- ^ Close active document.
| CloseThis -- ^ Close a specific tab. | CloseThis -- ^ Close a specific tab.
{ docToClose :: Unique } { docToClose :: !Unique }
deriving stock Show deriving stock Show
pattern JustClose, SaveAndClose, CancelClose :: Int32 pattern JustClose, SaveAndClose, CancelClose :: Int32
@ -364,19 +408,20 @@ instance HandleAction Close where
cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose cancelButton <- GTK.dialogAddButton dialog "Cancel" CancelClose
GTK.dialogSetDefaultResponse dialog 1 GTK.dialogSetDefaultResponse dialog 1
for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton" for_ [ closeButton, saveButton, cancelButton ] \ button -> widgetAddClass button "dialogButton"
choice <- GTK.dialogRun dialog GTK.widgetShow dialog
GTK.widgetDestroy dialog void $ GTK.onDialogResponse dialog \ choice -> do
case choice of case choice of
JustClose -> closeDocument isActiveDoc documentUnique JustClose -> closeDocument isActiveDoc documentUnique
SaveAndClose -> save uiElts vars False SaveAndClose -> save uiElts vars False
_ -> pure () _ -> pure ()
GTK.windowDestroy dialog
| otherwise | otherwise
-> closeDocument isActiveDoc documentUnique -> closeDocument isActiveDoc documentUnique
where where
closeDocument :: Bool -> Unique -> IO () closeDocument :: Bool -> Unique -> IO ()
closeDocument isActiveDoc unique = do closeDocument isActiveDoc unique = do
removeFileTab vars unique removeFileTab uiElts vars unique
when isActiveDoc do when isActiveDoc do
uiUpdateAction <- STM.atomically do uiUpdateAction <- STM.atomically do
STM.writeTVar activeDocumentTVar Nothing STM.writeTVar activeDocumentTVar Nothing
@ -390,20 +435,41 @@ instance HandleAction Close where
-- Switch document -- -- Switch document --
--------------------- ---------------------
data SwitchTo = SwitchTo Unique data SwitchFromTo =
SwitchFromTo
{ mbPrevActiveDocUnique :: !( Maybe Unique )
, newActiveDocUnique :: !Unique
}
deriving stock Show deriving stock Show
instance HandleAction SwitchTo where instance HandleAction SwitchFromTo where
handleAction handleAction
uiElts uiElts
vars@( Variables {..} ) vars@( Variables {..} )
( SwitchTo newUnique ) = do ( 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 uiUpdateAction <- STM.atomically do
STM.writeTVar activeDocumentTVar ( Just newUnique ) STM.writeTVar activeDocumentTVar ( Just newActiveDocUnique )
mbHist <- Map.lookup newUnique <$> STM.readTVar openDocumentsTVar mbHist <- Map.lookup newActiveDocUnique <$> STM.readTVar openDocumentsTVar
uiUpdateAction <- updateUIAction uiElts vars uiUpdateAction <- updateUIAction uiElts vars
pure do pure do
uiUpdateAction 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 updateHistoryState uiElts mbHist
uiUpdateAction uiUpdateAction
@ -415,10 +481,11 @@ data Quit = Quit
deriving stock Show deriving stock Show
instance HandleAction Quit where instance HandleAction Quit where
handleAction ( UIElements { window } ) _ _ = quitEverything window handleAction ( UIElements { application, window } ) _ _ =
quitEverything application window
quitEverything :: GTK.Window -> IO () quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
quitEverything window = GTK.widgetDestroy window *> GTK.mainQuit quitEverything = GTK.applicationRemoveWindow
---------------- ----------------
-- Undo & Redo -- -- Undo & Redo --
@ -556,17 +623,20 @@ data ToggleGuides = ToggleGuides
deriving stock Show deriving stock Show
instance HandleAction ToggleGuides where instance HandleAction ToggleGuides where
handleAction ( UIElements { viewport = Viewport {..}, menu } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do handleAction ( UIElements { viewport = Viewport {..} } ) ( Variables { recomputeStrokesTVar, showGuidesTVar } ) _ = do
guidesWereShown <- STM.atomically do _guidesWereShown <- STM.atomically do
guidesWereShown <- STM.readTVar showGuidesTVar guidesWereShown <- STM.readTVar showGuidesTVar
STM.writeTVar showGuidesTVar ( not guidesWereShown ) STM.writeTVar showGuidesTVar ( not guidesWereShown )
pure guidesWereShown pure guidesWereShown
let --let
newText :: Text -- newText :: Text
newText -- newText
| guidesWereShown = "Show guides" -- | guidesWereShown = "Show guides"
| otherwise = "Hide guides" -- | otherwise = "Hide guides"
GTK.menuItemSetLabel ( menuItem $ toggleGuides $ menuItemSubmenu $ view menu ) newText -- toggleGuidesWidget :: GTK.Button
-- toggleGuidesWidget = menuItemWidget . toggleGuides . sectionItems . viewMenu4 . menuItemSubmenu . view
-- $ menuObject
--GTK.buttonSetLabel toggleGuidesWidget newText
STM.atomically ( STM.writeTVar recomputeStrokesTVar True ) STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea GTK.widgetQueueDraw drawingArea
@ -835,7 +905,8 @@ instance HandleAction MouseRelease where
changeText = "Create guide" changeText = "Create guide"
pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} ) pure ( UpdateDoc . UpdateDocumentTo $ HistoryChange {..} )
| otherwise | otherwise
-> pure Don'tModifyDoc -> pure ( UpdateDoc . UpdateDocumentTo $ TrivialChange doc )
-- ^^ force an UI update when releasing a guide inside a ruler area
where where
createGuide :: Bool createGuide :: Bool
createGuide createGuide
@ -991,29 +1062,27 @@ instance HandleAction MouseRelease where
-- Scrolling -- -- Scrolling --
--------------- ---------------
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
deriving stock Show deriving stock Show
instance HandleAction Scroll where instance HandleAction Scroll where
handleAction handleAction
uiElts@( UIElements { viewport = Viewport {..} } ) uiElts
vars@( Variables {..} ) vars@( Variables {..} )
( Scroll ( Point2D x y ) ( Vector2D dx dy ) ) = do ( Scroll mbMousePos ( Vector2D dx dy ) ) = do
viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea --viewportWidth <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedWidth viewportDrawingArea
viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea --viewportHeight <- fromIntegral @_ @Double <$> GTK.widgetGetAllocatedHeight viewportDrawingArea
unless ( dx == 0 && dy == 0 ) do unless ( dx == 0 && dy == 0 ) do
modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do modifyingCurrentDocument uiElts vars \ ( doc@( Document { viewportCenter = oldCenter, zoomFactor = oldZoomFactor } ) ) -> do
modifiers <- STM.readTVar modifiersTVar modifiers <- STM.readTVar modifiersTVar
let 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 :: Point2D Double
mousePos = toViewport ( Point2D x y ) mousePos = fromMaybe oldCenter mbMousePos
finalMousePos :: Point2D Double
newDoc :: Document newDoc :: Document
newDoc ( newDoc, finalMousePos )
-- Zooming using 'Control'. -- Zooming using 'Control'.
| any ( \ case { Control _ -> True; _ -> False } ) modifiers | any ( \ case { Control _ -> True; _ -> False } ) modifiers
= let = let
@ -1027,27 +1096,20 @@ instance HandleAction Scroll where
newCenter newCenter
= ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double ) = ( 1 - oldZoomFactor / newZoomFactor ) *^ ( oldCenter --> mousePos :: Vector2D Double )
• oldCenter • oldCenter
in doc { zoomFactor = newZoomFactor, viewportCenter = newCenter } in ( doc { zoomFactor = newZoomFactor, viewportCenter = newCenter }, mousePos )
-- Vertical scrolling turned into horizontal scrolling using 'Shift'. -- Vertical scrolling turned into horizontal scrolling using 'Shift'.
| dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers | dx == 0 && any ( \ case { Shift _ -> True; _ -> False } ) modifiers
= let = let
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dy 0 ) • oldCenter
in doc { viewportCenter = newCenter } in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
-- Vertical scrolling. -- Vertical scrolling.
| otherwise | otherwise
= let = let
newCenter :: Point2D Double newCenter :: Point2D Double
newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter newCenter = ( ( 25 / oldZoomFactor ) *^ Vector2D dx dy ) • oldCenter
in doc { viewportCenter = newCenter } in ( doc { viewportCenter = newCenter }, ( oldCenter --> newCenter :: Vector2D Double ) • mousePos )
finalZoomFactor :: Double for_ mbMousePos \ _ ->
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 ) STM.writeTVar mousePosTVar ( Just finalMousePos )
pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc ) pure ( UpdateDoc . UpdateDocumentTo . TrivialChange $ newDoc )
@ -1067,7 +1129,7 @@ instance HandleAction KeyboardPress where
for_ ( modifierKey keyCode ) for_ ( modifierKey keyCode )
( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert ) ( STM.atomically . STM.modifyTVar' modifiersTVar . Set.insert )
case keyCode of case fromIntegral keyCode of
GDK.KEY_Escape -> handleAction uiElts vars Quit GDK.KEY_Escape -> handleAction uiElts vars Quit

33
src/app/MetaBrush/Action.hs-boot
View file

@ -1,3 +1,5 @@
{-# LANGUAGE MonoLocalBinds #-}
module MetaBrush.Action where module MetaBrush.Action where
-- base -- base
@ -7,6 +9,14 @@ import Data.Word
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- hashable
import Data.Hashable
( Hashable )
-- text
import Data.Text
( Text )
-- MetaBrush -- MetaBrush
import Math.Vector2D import Math.Vector2D
( Point2D, 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 class HandleAction action where
handleAction :: UIElements -> Variables -> action -> IO () handleAction :: UIElements -> Variables -> action -> IO ()
@ -44,15 +63,19 @@ instance HandleAction SaveAs
data Close data Close
= CloseActive = CloseActive
| CloseThis | CloseThis
{ docToClose :: Unique } { docToClose :: !Unique }
instance HandleAction Close instance HandleAction Close
data SwitchTo = SwitchTo Unique data SwitchFromTo =
instance HandleAction SwitchTo SwitchFromTo
{ mbPrevActiveDocUnique :: !( Maybe Unique )
, newActiveDocUnique :: !Unique
}
instance HandleAction SwitchFromTo
data Quit = Quit data Quit = Quit
instance HandleAction Quit instance HandleAction Quit
quitEverything :: GTK.Window -> IO () quitEverything :: GTK.IsWindow window => GTK.Application -> window -> IO ()
data Undo = Undo data Undo = Undo
instance HandleAction Undo instance HandleAction Undo
@ -99,7 +122,7 @@ instance HandleAction MouseClick
data MouseRelease = MouseRelease Word32 ( Point2D Double ) data MouseRelease = MouseRelease Word32 ( Point2D Double )
instance HandleAction MouseRelease instance HandleAction MouseRelease
data Scroll = Scroll ( Point2D Double ) ( Vector2D Double ) data Scroll = Scroll ( Maybe ( Point2D Double ) ) ( Vector2D Double )
instance HandleAction Scroll instance HandleAction Scroll
data KeyboardPress = KeyboardPress Word32 data KeyboardPress = KeyboardPress Word32

498
src/app/MetaBrush/Application.hs Normal file
View file

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

94
src/app/MetaBrush/Asset/Colours.hs
View file

@ -1,13 +1,13 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}
module MetaBrush.Asset.Colours module MetaBrush.Asset.Colours
( ColourRecord(..), ColourType ( ColourRecord(..)
, Colours, getColours , Colours, getColours
) )
where where
@ -42,61 +42,53 @@ data ColourRecord a
} }
deriving stock ( Show, Functor, Foldable, Traversable ) deriving stock ( Show, Functor, Foldable, Traversable )
data ColourType newtype ColourName
= Colour = ColourName { colourName :: Text }
| BackgroundColour
deriving stock Show
data ColourName
= ColourName
{ colourName :: !Text
, colourType :: !ColourType
, stateFlags :: ![ GTK.StateFlags ]
}
deriving stock Show deriving stock Show
colourNames :: ColourRecord ColourName colourNames :: ColourRecord ColourName
colourNames = Colours colourNames = Colours
{ bg = ColourName "bg" BackgroundColour [ GTK.StateFlagsNormal ] { bg = ColourName "bg"
, active = ColourName "active" BackgroundColour [ GTK.StateFlagsNormal ] , active = ColourName "active"
, close = ColourName "close" Colour [ GTK.StateFlagsNormal ] , close = ColourName "close"
, highlight = ColourName "highlight" Colour [ GTK.StateFlagsNormal ] , highlight = ColourName "highlight"
, cursor = ColourName "cursor" Colour [ GTK.StateFlagsNormal ] , cursor = ColourName "cursor"
, cursorOutline = ColourName "cursorStroke" Colour [ GTK.StateFlagsNormal ] , cursorOutline = ColourName "cursorStroke"
, cursorIndicator = ColourName "cursorIndicator" Colour [ GTK.StateFlagsNormal ] , cursorIndicator = ColourName "cursorIndicator"
, plain = ColourName "plain" Colour [ GTK.StateFlagsNormal ] , plain = ColourName "plain"
, base = ColourName "base" Colour [ GTK.StateFlagsNormal ] , base = ColourName "base"
, splash = ColourName "splash" Colour [ GTK.StateFlagsNormal ] , splash = ColourName "splash"
, pathPoint = ColourName "pathPoint" Colour [ GTK.StateFlagsNormal ] , pathPoint = ColourName "pathPoint"
, pathPointOutline = ColourName "pathPointStroke" Colour [ GTK.StateFlagsNormal ] , pathPointOutline = ColourName "pathPointStroke"
, controlPoint = ColourName "controlPoint" Colour [ GTK.StateFlagsNormal ] , controlPoint = ColourName "controlPoint"
, controlPointOutline = ColourName "controlPointStroke" Colour [ GTK.StateFlagsNormal ] , controlPointOutline = ColourName "controlPointStroke"
, path = ColourName "path" Colour [ GTK.StateFlagsNormal ] , path = ColourName "path"
, brush = ColourName "brush" Colour [ GTK.StateFlagsNormal ] , brush = ColourName "brush"
, brushStroke = ColourName "brushStroke" Colour [ GTK.StateFlagsNormal ] , brushStroke = ColourName "brushStroke"
, brushCenter = ColourName "brushCenter" Colour [ GTK.StateFlagsNormal ] , brushCenter = ColourName "brushCenter"
, pointHover = ColourName "pointHover" Colour [ GTK.StateFlagsNormal ] , pointHover = ColourName "pointHover"
, pointSelected = ColourName "pointSelected" Colour [ GTK.StateFlagsNormal ] , pointSelected = ColourName "pointSelected"
, viewport = ColourName "viewport" BackgroundColour [ GTK.StateFlagsNormal ] , viewport = ColourName "viewport"
, viewportScrollbar = ColourName "viewportScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , viewportScrollbar = ColourName "viewportScrollbar"
, tabScrollbar = ColourName "tabScrollbar" BackgroundColour [ GTK.StateFlagsNormal ] , tabScrollbar = ColourName "tabScrollbar"
, rulerBg = ColourName "ruler" BackgroundColour [ GTK.StateFlagsNormal ] , rulerBg = ColourName "ruler"
, rulerTick = ColourName "rulerTick" Colour [ GTK.StateFlagsNormal ] , rulerTick = ColourName "rulerTick"
, guide = ColourName "guide" Colour [ GTK.StateFlagsNormal ] , guide = ColourName "guide"
, magnifier = ColourName "magnifier" Colour [ GTK.StateFlagsNormal ] , magnifier = ColourName "magnifier"
, glass = ColourName "glass" Colour [ GTK.StateFlagsNormal ] , glass = ColourName "glass"
, selected = ColourName "selected" Colour [ GTK.StateFlagsNormal ] , selected = ColourName "selected"
, selectedOutline = ColourName "selectedOutline" Colour [ GTK.StateFlagsNormal ] , selectedOutline = ColourName "selectedOutline"
} }
type Colours = ColourRecord GDK.RGBA type Colours = ColourRecord GDK.RGBA
getColours :: GTK.WidgetPath -> IO Colours getColours
getColours windowWidgetPath = :: ( GTK.IsStyleProvider styleProvider )
for colourNames \ ( ColourName {..} ) -> do => styleProvider -> IO Colours
style <- GTK.styleContextNew getColours provider =
GTK.styleContextSetPath style windowWidgetPath 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 GTK.styleContextAddClass style colourName
case colourType of GTK.styleContextGetColor style
BackgroundColour -> GTK.styleContextGetBackgroundColor style stateFlags
Colour -> GTK.styleContextGetColor style stateFlags

47
src/app/MetaBrush/Context.hs
View file

@ -3,7 +3,7 @@
module MetaBrush.Context module MetaBrush.Context
( UIElements(..), Variables(..) ( UIElements(..), Variables(..)
, LR(..), Modifier(..), modifierKey, modifierType , LR(..), Modifier(..), modifierKey
, HoldAction(..), GuideAction(..), PartialPath(..) , HoldAction(..), GuideAction(..), PartialPath(..)
) )
where where
@ -24,9 +24,12 @@ import Data.Map.Strict
import qualified GI.Cairo.Render as Cairo import qualified GI.Cairo.Render as Cairo
( Render ) ( Render )
-- gi-gtk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
-- gi-gio
import qualified GI.Gio as GIO
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -43,6 +46,8 @@ import Math.Bezier.Cubic.Fit
( FitParameters ) ( FitParameters )
import Math.Vector2D import Math.Vector2D
( Point2D ) ( Point2D )
import {-# SOURCE #-} MetaBrush.Action
( ActionName )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Brush import MetaBrush.Brush
@ -54,11 +59,9 @@ import MetaBrush.Document.History
import MetaBrush.Document.Selection import MetaBrush.Document.Selection
( DragMoveSelect ) ( DragMoveSelect )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
( FileBar ) ( FileBar, FileBarTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar ) ( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu
( Menu, ResourceType(Object) )
import {-# SOURCE #-} MetaBrush.UI.ToolBar import {-# SOURCE #-} MetaBrush.UI.ToolBar
( Tool, Mode ) ( Tool, Mode )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
@ -70,13 +73,16 @@ import MetaBrush.Unique
data UIElements data UIElements
= UIElements = UIElements
{ window :: !GTK.Window { application :: !GTK.Application
, title :: !GTK.Label , window :: !GTK.ApplicationWindow
, titleBar :: !GTK.Box , windowKeys :: !GTK.EventControllerKey
, titleBar :: !GTK.HeaderBar
, titleLabel :: !GTK.Label
, fileBar :: !FileBar , fileBar :: !FileBar
, viewport :: !Viewport , viewport :: !Viewport
, infoBar :: !InfoBar , infoBar :: !InfoBar
, menu :: Menu Object -- needs to be lazy for "recursive do" , menuBar :: GTK.PopoverMenuBar -- needs to be lazy for RecursiveDo
, menuActions :: !( HashMap ActionName GIO.SimpleAction )
, colours :: !Colours , colours :: !Colours
} }
@ -95,7 +101,7 @@ data Variables
, modeTVar :: !( STM.TVar Mode ) , modeTVar :: !( STM.TVar Mode )
, debugTVar :: !( STM.TVar Bool ) , debugTVar :: !( STM.TVar Bool )
, partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) ) , partialPathTVar :: !( STM.TVar ( Maybe PartialPath ) )
, fileBarTabsTVar :: !( STM.TVar ( Map Unique ( GTK.Box, GTK.RadioButton ) ) ) , fileBarTabsTVar :: !( STM.TVar ( Map Unique FileBarTab ) )
, showGuidesTVar :: !( STM.TVar Bool ) , showGuidesTVar :: !( STM.TVar Bool )
, maxHistorySizeTVar :: !( STM.TVar Int ) , maxHistorySizeTVar :: !( STM.TVar Int )
, fitParametersTVar :: !( STM.TVar FitParameters ) , fitParametersTVar :: !( STM.TVar FitParameters )
@ -113,19 +119,14 @@ data Modifier
deriving stock ( Show, Eq, Ord ) deriving stock ( Show, Eq, Ord )
modifierKey :: Word32 -> Maybe Modifier modifierKey :: Word32 -> Maybe Modifier
modifierKey GDK.KEY_Control_L = Just ( Control L ) modifierKey n = case fromIntegral n of
modifierKey GDK.KEY_Control_R = Just ( Control R ) GDK.KEY_Control_L -> Just ( Control L )
modifierKey GDK.KEY_Shift_L = Just ( Shift L ) GDK.KEY_Control_R -> Just ( Control R )
modifierKey GDK.KEY_Shift_R = Just ( Shift R ) GDK.KEY_Shift_L -> Just ( Shift L )
modifierKey GDK.KEY_Alt_L = Just ( Alt L ) GDK.KEY_Shift_R -> Just ( Shift R )
modifierKey GDK.KEY_Alt_R = Just ( Alt R ) GDK.KEY_Alt_L -> Just ( Alt L )
modifierKey _ = Nothing GDK.KEY_Alt_R -> Just ( Alt R )
_ -> Nothing
modifierType :: Modifier -> GDK.ModifierType
modifierType ( Control _ ) = GDK.ModifierTypeControlMask
modifierType ( Alt _ ) = GDK.ModifierTypeMod1Mask
modifierType ( Shift _ ) = GDK.ModifierTypeShiftMask
data GuideAction data GuideAction
= CreateGuide !Ruler = CreateGuide !Ruler

67
src/app/MetaBrush/Document/Update.hs
View file

@ -3,6 +3,7 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
@ -38,6 +39,9 @@ import qualified Data.Map.Strict as Map
import Data.Generics.Product.Fields import Data.Generics.Product.Fields
( field' ) ( field' )
-- gi-gio
import qualified GI.Gio as GIO
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -65,22 +69,25 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
( MaybeT(..) ) ( MaybeT(..) )
-- unordered-containers
import qualified Data.HashMap.Lazy as HashMap
( lookup )
-- MetaBrush -- MetaBrush
import {-# SOURCE #-} MetaBrush.Action
( ActionName(..) )
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ) ( UIElements(..), Variables(..) )
import MetaBrush.Document import MetaBrush.Document
( Document(..), DocumentContent(..) ) ( Document(..), DocumentContent(..) )
import MetaBrush.Document.History import MetaBrush.Document.History
( DocumentHistory(..) ( DocumentHistory(..), atStart, atEnd
, newFutureStep, affirmPresent , newFutureStep, affirmPresent
, atStart, atEnd
) )
import {-# SOURCE #-} MetaBrush.UI.FileBar import {-# SOURCE #-} MetaBrush.UI.FileBar
( removeFileTab ) ( FileBarTab(..), removeFileTab )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
( updateInfoBar ) ( updateInfoBar )
import MetaBrush.UI.Menu
( ResourceType(..), MenuItem(..), Menu(..), EditMenu(..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..) ) ( Viewport(..) )
import MetaBrush.Util import MetaBrush.Util
@ -145,7 +152,7 @@ instance DocumentModification DocModification where
-- --
-- Does nothing if no document is currently active. -- Does nothing if no document is currently active.
modifyingCurrentDocument :: DocumentModification modif => UIElements -> Variables -> ( Document -> STM modif ) -> IO () 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 mbAction <- STM.atomically . runMaybeT $ do
unique <- MaybeT ( STM.readTVar activeDocumentTVar ) unique <- MaybeT ( STM.readTVar activeDocumentTVar )
oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar ) oldDoc <- MaybeT ( fmap present . Map.lookup unique <$> STM.readTVar openDocumentsTVar )
@ -185,25 +192,21 @@ modifyingCurrentDocument uiElts@( UIElements { .. } ) vars@( Variables {..} ) f
uiUpdateAction <- updateUIAction uiElts vars uiUpdateAction <- updateUIAction uiElts vars
pure $ Ap do pure $ Ap do
uiUpdateAction uiUpdateAction
GTK.widgetSetSensitive undoMenuItem True for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
GTK.widgetSetSensitive redoMenuItem False for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
pure pure
do do
forOf_ docFold modif \ mbNewDoc -> do forOf_ docFold modif \ mbNewDoc -> do
case mbNewDoc of case mbNewDoc of
CloseDocument -> removeFileTab vars ( documentUnique oldDoc ) CloseDocument -> removeFileTab uiElts vars ( documentUnique oldDoc )
_ -> pure () _ -> pure ()
uiUpdateAction uiUpdateAction
sequenceAOf_ actionFold modif sequenceAOf_ actionFold modif
sequenceA_ mbAction 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 -> Variables -> STM ( IO () )
updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do updateUIAction uiElts@( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables {..} ) = do
mbDocHist <- activeDocument vars mbDocHist <- activeDocument vars
let let
mbDoc :: Maybe Document mbDoc :: Maybe Document
@ -214,18 +217,18 @@ updateUIAction ( UIElements { viewport = Viewport {..}, .. } ) vars@( Variables
mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar mbActiveTab <- Map.lookup ( documentUnique doc ) <$> STM.readTVar fileBarTabsTVar
pure ( (,) <$> mbActiveTab <*> mbDoc ) pure ( (,) <$> mbActiveTab <*> mbDoc )
pure do pure do
updateTitle window title mbTitleText updateTitle window titleLabel mbTitleText
updateInfoBar viewportDrawingArea infoBar vars mbDoc updateInfoBar viewportDrawingArea infoBar vars mbDoc
for_ mbActiveTabDoc \ ( ( activeTab, activeTabLabel ), activeDoc ) -> do for_ mbActiveTabDoc \ ( FileBarTab { fileBarTab, fileBarTabButton, fileBarTabCloseArea }, activeDoc ) -> do
GTK.buttonSetLabel activeTabLabel ( displayName activeDoc ) GTK.buttonSetLabel fileBarTabButton ( displayName activeDoc )
GTK.widgetQueueDraw activeTab GTK.widgetQueueDraw fileBarTab
GTK.widgetQueueDraw fileBarTabCloseArea
updateHistoryState uiElts mbDocHist
STM.atomically ( STM.writeTVar recomputeStrokesTVar True ) STM.atomically ( STM.writeTVar recomputeStrokesTVar True )
for_ [ rulerCornerDrawingArea, topRulerDrawingArea, leftRulerDrawingArea ] \ drawingArea -> do
GTK.widgetQueueDraw drawingArea
updateTitle :: GTK.Window -> GTK.Label -> Maybe ( Text, Bool ) -> IO () updateTitle :: GTK.IsWindow window => window -> GTK.Label -> Maybe ( Text, Bool ) -> IO ()
updateTitle window title mbTitleText = do updateTitle window titleLabel mbTitleText = do
GTK.labelSetText title titleText GTK.labelSetText titleLabel titleText
GTK.setWindowTitle window titleText GTK.setWindowTitle window titleText
where where
titleText :: Text titleText :: Text
@ -241,18 +244,12 @@ updateHistoryState :: UIElements -> Maybe DocumentHistory -> IO ()
updateHistoryState ( UIElements {..} ) mbHist = updateHistoryState ( UIElements {..} ) mbHist =
case mbHist of case mbHist of
Nothing -> do Nothing -> do
GTK.widgetSetSensitive undoMenuItem False for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
GTK.widgetSetSensitive redoMenuItem False for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
Just hist -> do Just hist -> do
if atStart hist if atStart hist
then GTK.widgetSetSensitive undoMenuItem False then for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
else GTK.widgetSetSensitive undoMenuItem True else for_ ( HashMap.lookup ( WinAction "undo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
if atEnd hist if atEnd hist
then GTK.widgetSetSensitive redoMenuItem False then for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` False )
else GTK.widgetSetSensitive redoMenuItem True else for_ ( HashMap.lookup ( WinAction "redo" ) menuActions ) ( `GIO.setSimpleActionEnabled` True )
where
editMenu :: EditMenu Object
editMenu = menuItemSubmenu ( edit menu )
undoMenuItem, redoMenuItem :: GTK.MenuItem
undoMenuItem = menuItem $ undo $ editMenu
redoMenuItem = menuItem $ redo $ editMenu

118
src/app/MetaBrush/Event.hs
View file

@ -12,6 +12,10 @@ import Control.Monad
( void ) ( void )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
import Data.Int
( Int32 )
import Data.Word
( Word32 )
-- gi-gdk -- gi-gdk
import qualified GI.Gdk as GDK import qualified GI.Gdk as GDK
@ -19,6 +23,10 @@ import qualified GI.Gdk as GDK
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- stm
import qualified Control.Concurrent.STM.TVar as STM
( readTVarIO )
-- MetaBrush -- MetaBrush
import Math.Vector2D import Math.Vector2D
( Point2D(..), Vector2D(..) ) ( Point2D(..), Vector2D(..) )
@ -32,7 +40,7 @@ import MetaBrush.Action
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ) ( UIElements(..), Variables(..) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..), Ruler(..) ) ( Viewport(..), ViewportEventControllers(..), Ruler(..) )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -40,72 +48,74 @@ handleEvents :: UIElements -> Variables -> IO ()
handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do handleEvents elts@( UIElements { viewport = Viewport {..}, .. } ) vars = do
-- Mouse events -- Mouse events
afterWidgetMouseEvent viewportDrawingArea ViewportOrigin afterWidgetMouseEvent viewportEventControllers ViewportOrigin
afterWidgetMouseEvent rulerCornerDrawingArea ( RulerOrigin RulerCorner ) afterWidgetMouseEvent rulerCornerEventControllers ( RulerOrigin RulerCorner )
afterWidgetMouseEvent leftRulerDrawingArea ( RulerOrigin LeftRuler ) afterWidgetMouseEvent leftRulerEventControllers ( RulerOrigin LeftRuler )
afterWidgetMouseEvent topRulerDrawingArea ( RulerOrigin TopRuler ) afterWidgetMouseEvent topRulerEventControllers ( RulerOrigin TopRuler )
-- Keyboard events -- Keyboard events
void $ GTK.onWidgetKeyPressEvent window ( handleKeyboardPressEvent elts vars ) void $ GTK.onEventControllerKeyKeyPressed windowKeys
void $ GTK.onWidgetKeyReleaseEvent window ( handleKeyboardReleaseEvent elts vars ) ( handleKeyboardPressEvent elts vars )
void $ GTK.onEventControllerKeyKeyReleased windowKeys
( handleKeyboardReleaseEvent elts vars )
-- Window quit -- Window quit
void $ GTK.onWidgetDestroy window ( quitEverything window ) void $ GTK.onApplicationQueryEnd application ( quitEverything application window )
where where
afterWidgetMouseEvent :: GTK.DrawingArea -> ActionOrigin -> IO () afterWidgetMouseEvent :: ViewportEventControllers -> ActionOrigin -> IO ()
afterWidgetMouseEvent drawingArea eventOrigin = do afterWidgetMouseEvent ( ViewportEventControllers {..}) eventOrigin = do
void $ GTK.afterWidgetMotionNotifyEvent drawingArea ( handleMotionEvent elts vars eventOrigin ) void $ GTK.afterEventControllerMotionMotion viewportMotionController
void $ GTK.afterWidgetScrollEvent drawingArea ( handleScrollEvent elts vars eventOrigin ) ( handleMotionEvent elts vars eventOrigin )
void $ GTK.afterWidgetButtonPressEvent drawingArea ( handleMouseButtonEvent elts vars eventOrigin ) void $ GTK.afterEventControllerScrollScroll viewportScrollController
void $ GTK.afterWidgetButtonReleaseEvent drawingArea ( handleMouseButtonRelease elts vars eventOrigin ) ( handleScrollEvent elts vars )
void $ GTK.afterGestureClickPressed viewportClicksController
( handleMouseButtonEvent elts vars eventOrigin viewportClicksController )
void $ GTK.afterGestureClickReleased viewportClicksController
( handleMouseButtonRelease elts vars eventOrigin viewportClicksController )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Mouse events. -- Mouse events.
handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventMotion -> IO Bool handleMotionEvent :: UIElements -> Variables -> ActionOrigin -> ( Double -> Double -> IO () )
handleMotionEvent elts vars eventOrigin eventMotion = do handleMotionEvent elts vars eventOrigin x y = do
x <- GDK.getEventMotionX eventMotion
y <- GDK.getEventMotionY eventMotion
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( MouseMove mousePos ) handleAction elts vars ( MouseMove mousePos )
pure True
handleScrollEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventScroll -> IO Bool handleScrollEvent :: UIElements -> Variables -> ( Double -> Double -> IO Bool )
handleScrollEvent elts vars eventOrigin scrollEvent = do handleScrollEvent elts vars dx dy = do
dx <- GDK.getEventScrollDeltaX scrollEvent mbMousePos <- STM.readTVarIO ( mousePosTVar vars )
dy <- GDK.getEventScrollDeltaY scrollEvent handleAction elts vars ( Scroll mbMousePos ( Vector2D dx dy ) )
x <- GDK.getEventScrollX scrollEvent
y <- GDK.getEventScrollY scrollEvent
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( Scroll mousePos ( Vector2D dx dy ) )
pure False pure False
handleMouseButtonEvent :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool handleMouseButtonEvent
handleMouseButtonEvent elts vars eventOrigin mouseClickEvent = do :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
ty <- GDK.getEventButtonType mouseClickEvent -> ( Int32 -> Double -> Double -> IO () )
handleMouseButtonEvent elts@( UIElements{ viewport = Viewport {..} } ) vars eventOrigin gestureClick nbClicks x y = do
let let
mbClick :: Maybe MouseClickType mbClick :: Maybe MouseClickType
mbClick = case ty of mbClick
GDK.EventTypeButtonPress -> Just SingleClick | nbClicks >= 2
GDK.EventType2buttonPress -> Just DoubleClick = Just DoubleClick
_ -> Nothing | nbClicks == 1
= Just SingleClick
| otherwise
= Nothing
for_ mbClick \ click -> do for_ mbClick \ click -> do
button <- GDK.getEventButtonButton mouseClickEvent _ <- GTK.widgetGrabFocus viewportDrawingArea
x <- GDK.getEventButtonX mouseClickEvent button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
y <- GDK.getEventButtonY mouseClickEvent -- ^^^^^ use button number 1 if no button number is reported (button == 0)
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( MouseClick eventOrigin click button mousePos ) handleAction elts vars ( MouseClick eventOrigin click button mousePos )
pure False
handleMouseButtonRelease :: UIElements -> Variables -> ActionOrigin -> GDK.EventButton -> IO Bool handleMouseButtonRelease
handleMouseButtonRelease elts vars eventOrigin mouseReleaseEvent = do :: UIElements -> Variables -> ActionOrigin -> GTK.GestureClick
button <- GDK.getEventButtonButton mouseReleaseEvent -> ( Int32 -> Double -> Double -> IO () )
x <- GDK.getEventButtonX mouseReleaseEvent handleMouseButtonRelease elts vars eventOrigin gestureClick _ x y = do
y <- GDK.getEventButtonY mouseReleaseEvent button <- max 1 <$> GTK.gestureSingleGetCurrentButton gestureClick
-- ^^^^^ same as above
mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y ) mousePos <- adjustMousePosition ( viewport elts ) eventOrigin ( Point2D x y )
handleAction elts vars ( MouseRelease button mousePos ) handleAction elts vars ( MouseRelease button mousePos )
pure False
adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double ) adjustMousePosition :: Viewport -> ActionOrigin -> Point2D Double -> IO ( Point2D Double )
adjustMousePosition _ ViewportOrigin pt = pure pt adjustMousePosition _ ViewportOrigin pt = pure pt
@ -125,14 +135,16 @@ adjustMousePosition ( Viewport {..} ) ( RulerOrigin ruler ) ( Point2D x y ) =
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Keyboard events. -- Keyboard events.
handleKeyboardPressEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool handleKeyboardPressEvent
handleKeyboardPressEvent elts vars evt = do :: UIElements -> Variables
keyCode <- GDK.getEventKeyKeyval evt -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO Bool )
handleAction elts vars ( KeyboardPress keyCode ) handleKeyboardPressEvent elts vars keyVal _ _ = do
handleAction elts vars ( KeyboardPress keyVal )
pure False -- allow the default handler to run pure False -- allow the default handler to run
handleKeyboardReleaseEvent :: UIElements -> Variables -> GDK.EventKey -> IO Bool
handleKeyboardReleaseEvent elts vars evt = do handleKeyboardReleaseEvent
keyCode <- GDK.getEventKeyKeyval evt :: UIElements -> Variables
handleAction elts vars ( KeyboardRelease keyCode ) -> ( Word32 -> Word32 -> [ GDK.ModifierType ] -> IO () )
pure False -- allow the default handler to run handleKeyboardReleaseEvent elts vars keyVal _ _ =
handleAction elts vars ( KeyboardRelease keyVal )

183
src/app/MetaBrush/UI/FileBar.hs
View file

@ -7,7 +7,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module MetaBrush.UI.FileBar module MetaBrush.UI.FileBar
( FileBar(..) ( FileBar(..), FileBarTab(..)
, createFileBar, newFileTab, removeFileTab , createFileBar, newFileTab, removeFileTab
, TabLocation(..) , TabLocation(..)
) )
@ -15,11 +15,9 @@ module MetaBrush.UI.FileBar
-- base -- base
import Control.Monad import Control.Monad
( join, unless, void ) ( join, void )
import Data.Foldable import Data.Foldable
( for_, sequenceA_ ) ( for_, sequenceA_ )
import Data.Int
( Int32 )
import Data.Traversable import Data.Traversable
( for ) ( for )
@ -31,13 +29,12 @@ import qualified Data.Map.Strict as Map
import qualified GI.Cairo.Render.Connector as Cairo import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext ) ( renderWithContext )
-- gi-gio
import qualified GI.Gio as GIO
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as 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 -- stm
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
( atomically ) ( atomically )
@ -48,9 +45,13 @@ import qualified Control.Concurrent.STM.TVar as STM
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
( runReaderT ) ( runReaderT )
-- unordered-containers
import Data.HashMap.Lazy
( HashMap )
-- MetaBrush -- MetaBrush
import MetaBrush.Action import {-# SOURCE #-} MetaBrush.Action
( SwitchTo(..), Close(..), handleAction ) ( ActionName, SwitchFromTo(..), Close(..), handleAction )
import MetaBrush.Asset.CloseTabButton import MetaBrush.Asset.CloseTabButton
( drawCloseTabButton ) ( drawCloseTabButton )
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
@ -67,16 +68,12 @@ import MetaBrush.Document.Update
( updateUIAction ) ( updateUIAction )
import {-# SOURCE #-} MetaBrush.UI.InfoBar import {-# SOURCE #-} MetaBrush.UI.InfoBar
( InfoBar ) ( InfoBar )
import {-# SOURCE #-} MetaBrush.UI.Menu
( Menu, ResourceType(Object) )
import MetaBrush.UI.Viewport import MetaBrush.UI.Viewport
( Viewport(..) ) ( Viewport(..) )
import MetaBrush.Unique import MetaBrush.Unique
( Unique, freshUnique, uniqueText ) ( Unique, freshUnique, uniqueText )
import MetaBrush.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ( widgetAddClass, widgetAddClasses )
, Exists(..)
)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -84,7 +81,14 @@ data FileBar
= FileBar = FileBar
{ fileBarBox :: !GTK.Box { fileBarBox :: !GTK.Box
, fileTabsBox :: !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 data TabLocation
@ -93,14 +97,12 @@ data TabLocation
deriving stock Show deriving stock Show
newFileTab newFileTab
:: Bool :: UIElements
-> UIElements
-> Variables -> Variables
-> Maybe DocumentHistory -> Maybe DocumentHistory
-> TabLocation -> TabLocation
-> IO () -> IO ()
newFileTab newFileTab
initialStage
uiElts@( UIElements { fileBar = FileBar {..}, .. } ) uiElts@( UIElements { fileBar = FileBar {..}, .. } )
vars@( Variables {..} ) vars@( Variables {..} )
mbDocHist mbDocHist
@ -116,18 +118,19 @@ newFileTab
pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq ) pure ( newHistory $ emptyDocument ( "Untitled " <> uniqueText newDocUniq ) newDocUniq )
let let
newUnique :: Unique thisTabDocUnique :: Unique
newUnique = documentUnique ( present newDocHist ) thisTabDocUnique = documentUnique ( present newDocHist )
-- TODO: make the file tab an EditableLabel
-- File tab elements. -- File tab elements.
pgButton <- GTK.radioButtonNewWithLabelFromWidget ( Just fileBarPhantomRadioButton ) ( displayName $ present newDocHist ) pgButton <- GTK.toggleButtonNewWithLabel ( displayName $ present newDocHist )
GTK.toggleButtonSetMode pgButton False -- don't display radio indicator GTK.toggleButtonSetGroup pgButton ( Just fileBarPhantomToggleButton )
closeFileButton <- GTK.buttonNew closeFileButton <- GTK.buttonNew
closeFileArea <- GTK.drawingAreaNew closeFileArea <- GTK.drawingAreaNew
GTK.containerAdd closeFileButton closeFileArea GTK.buttonSetChild closeFileButton ( Just closeFileArea )
void $ GTK.onWidgetDraw closeFileArea \ cairoContext -> do GTK.drawingAreaSetDrawFunc closeFileArea $ Just \ _ cairoContext _ _ -> void do
mbTabDoc <- fmap present . Map.lookup newUnique <$> STM.readTVarIO openDocumentsTVar mbTabDoc <- fmap present . Map.lookup thisTabDocUnique <$> STM.readTVarIO openDocumentsTVar
let let
unsaved :: Bool unsaved :: Bool
unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc unsaved = maybe False ( unsavedChanges . documentContent ) mbTabDoc
@ -137,104 +140,115 @@ newFileTab
-- Create box for file tab elements. -- Create box for file tab elements.
tab <- GTK.boxNew GTK.OrientationHorizontal 0 tab <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClasses tab [ "fileBarTab" ] widgetAddClasses tab [ "fileBarTab" ]
GTK.boxPackStart fileTabsBox tab False False 0 GTK.boxAppend tab pgButton
GTK.boxPackStart tab pgButton True True 0 GTK.boxAppend tab closeFileButton
GTK.boxPackStart tab closeFileButton False False 0
widgetAddClasses pgButton [ "fileBarTabButton" ] widgetAddClasses pgButton [ "fileBarTabButton" ]
widgetAddClasses closeFileButton [ "fileBarCloseButton" ] 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 case newTabLoc of
LastTab -> pure () LastTab ->
GTK.boxAppend fileTabsBox tab
AfterCurrentTab -> do AfterCurrentTab -> do
mbActiveTab <- fmap join $ STM.atomically do mbActiveTab <- fmap join $ STM.atomically do
mbUnique <- STM.readTVar activeDocumentTVar mbUnique <- STM.readTVar activeDocumentTVar
for mbUnique \ docUnique -> do for mbUnique \ docUnique -> do
Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
for_ mbActiveTab \ ( activeTab, _ ) -> do case mbActiveTab of
old_gValue <- GI.newGValue GI.gtypeInt Just ( FileBarTab { fileBarTab = activeTab } )
GTK.containerChildGetProperty fileTabsBox activeTab "position" old_gValue -> GTK.boxInsertChildAfter fileTabsBox tab ( Just activeTab )
new_gValue <- GI.toGValue @Int32 =<< ( +1 ) <$> GI.fromGValue @Int32 old_gValue _ -> GTK.boxAppend fileTabsBox tab
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
let
fileBarTab :: FileBarTab
fileBarTab =
FileBarTab
{ fileBarTab = tab
, fileBarTabButton = pgButton
, fileBarTabCloseArea = closeFileArea
}
-- Update the state: switch to this new document. -- Update the state: switch to this new document.
uiUpdateAction <- STM.atomically do uiUpdateAction <- STM.atomically do
STM.modifyTVar' openDocumentsTVar ( Map.insert newUnique newDocHist ) STM.modifyTVar' openDocumentsTVar ( Map.insert thisTabDocUnique newDocHist )
STM.modifyTVar' fileBarTabsTVar ( Map.insert newUnique ( tab, pgButton ) ) STM.modifyTVar' fileBarTabsTVar ( Map.insert thisTabDocUnique fileBarTab )
-- don't update UI if we are just creating file tabs for the first time STM.writeTVar activeDocumentTVar ( Just thisTabDocUnique )
-- (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 updateUIAction uiElts vars
uiUpdateAction uiUpdateAction
void $ GTK.onButtonClicked pgButton do void $ GTK.afterToggleButtonToggled pgButton do
isActive <- GTK.toggleButtonGetActive pgButton nowActive <- GTK.toggleButtonGetActive pgButton
flags <- GTK.widgetGetStateFlags tab flags <- GTK.widgetGetStateFlags tab
if isActive mbPrevActiveDocUnique <- STM.readTVarIO activeDocumentTVar
if nowActive
then do then do
GTK.widgetSetStateFlags tab ( GTK.StateFlagsActive : flags ) True -- If changing tabs, switch document.
handleAction uiElts vars ( SwitchTo newUnique ) -- 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 else do
GTK.widgetSetStateFlags tab ( filter ( /= GTK.StateFlagsActive ) flags ) True -- Otherwise, ensure the tab hasn't been toggled off on its own
GTK.widgetQueueDraw closeFileArea -- (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 void $ GTK.onButtonClicked closeFileButton do
GTK.widgetQueueDraw closeFileArea GTK.widgetQueueDraw closeFileArea
handleAction uiElts vars ( CloseThis newUnique ) handleAction uiElts vars ( CloseThis thisTabDocUnique )
-- 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 )
-- | Create a file bar: tabs allowing selection of the active document. -- | Create a file bar: tabs allowing selection of the active document.
-- --
-- Updates the active document when buttons are clicked. -- Updates the active document when buttons are clicked.
createFileBar createFileBar
:: Colours -> Variables :: 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 -> IO FileBar
createFileBar createFileBar
colours colours
vars@( Variables { openDocumentsTVar } ) vars@( Variables { openDocumentsTVar } )
window titleBar title viewport infoBar menu application window windowKeys titleBar titleLabel viewport infoBar menuBar menuActions
= do = do
-- Create file bar: box containing scrollable tabs, and a "+" button after it. -- Create file bar: box containing scrollable tabs, and a "+" button after it.
fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0 fileBarBox <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClass fileBarBox "fileBar" widgetAddClass fileBarBox "fileBar"
fileTabsScroll <- GTK.scrolledWindowNew ( Nothing @GTK.Adjustment ) ( Nothing @GTK.Adjustment ) fileTabsScroll <- GTK.scrolledWindowNew
GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever GTK.scrolledWindowSetPolicy fileTabsScroll GTK.PolicyTypeAutomatic GTK.PolicyTypeNever
GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True GTK.scrolledWindowSetOverlayScrolling fileTabsScroll True
GTK.widgetSetHexpand fileTabsScroll True
newFileButton <- GTK.buttonNewWithLabel "+" newFileButton <- GTK.buttonNewWithLabel "+"
widgetAddClasses newFileButton [ "newFileButton" ] widgetAddClasses newFileButton [ "newFileButton" ]
GTK.boxPackEnd fileBarBox newFileButton False False 0 GTK.boxAppend fileBarBox fileTabsScroll
GTK.boxPackStart fileBarBox fileTabsScroll True True 0 GTK.boxAppend fileBarBox newFileButton
GTK.widgetSetHalign newFileButton GTK.AlignEnd
fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0 fileTabsBox <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.containerAdd fileTabsScroll fileTabsBox GTK.scrolledWindowSetChild fileTabsScroll ( Just fileTabsBox )
widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ] widgetAddClasses fileTabsBox [ "fileBar", "plain", "text" ]
-- Phantom radio button for when no page is selected (e.g. no documents opened yet). -- Phantom toggle button for when no page is selected (e.g. no documents opened yet).
fileBarPhantomRadioButton <- GTK.radioButtonNew ( [] @GTK.RadioButton ) fileBarPhantomToggleButton <- GTK.toggleButtonNew
let let
fileBar :: FileBar fileBar :: FileBar
@ -244,13 +258,13 @@ createFileBar
documents <- STM.readTVarIO openDocumentsTVar documents <- STM.readTVarIO openDocumentsTVar
for_ documents \ doc -> for_ documents \ doc ->
newFileTab True newFileTab
uiElements vars uiElements vars
( Just doc ) ( Just doc )
LastTab LastTab
void $ GTK.onButtonClicked newFileButton do void $ GTK.onButtonClicked newFileButton do
newFileTab False newFileTab
uiElements vars uiElements vars
Nothing Nothing
LastTab LastTab
@ -258,15 +272,18 @@ createFileBar
pure fileBar pure fileBar
-- | Close a document: remove the corresponding file tab from the file bar. -- | Close a document: remove the corresponding file tab from the file bar.
removeFileTab :: Variables -> Unique -> IO () removeFileTab :: UIElements -> Variables -> Unique -> IO ()
removeFileTab ( Variables {..} ) docUnique = do removeFileTab
( UIElements { fileBar = FileBar { fileTabsBox } } )
( Variables {..} )
docUnique = do
cleanupAction <- STM.atomically do cleanupAction <- STM.atomically do
-- Remove the tab. -- Remove the tab.
mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar mbTab <- Map.lookup docUnique <$> STM.readTVar fileBarTabsTVar
for mbTab \ ( tab, _ ) -> do for mbTab \ ( FileBarTab { fileBarTab = tab } ) -> do
STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique ) STM.modifyTVar' openDocumentsTVar ( Map.delete docUnique )
STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique ) STM.modifyTVar' fileBarTabsTVar ( Map.delete docUnique )
pure ( GTK.widgetDestroy tab ) pure ( GTK.boxRemove fileTabsBox tab )
sequenceA_ cleanupAction sequenceA_ cleanupAction

39
src/app/MetaBrush/UI/FileBar.hs-boot
View file

@ -1,9 +1,6 @@
{-# LANGUAGE DataKinds #-}
module MetaBrush.UI.FileBar module MetaBrush.UI.FileBar
( FileBar(..) ( FileBar(..), FileBarTab(..), TabLocation(..)
, createFileBar, newFileTab, removeFileTab , removeFileTab
, TabLocation(..)
) )
where where
@ -11,18 +8,8 @@ module MetaBrush.UI.FileBar
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
-- MetaBrush -- MetaBrush
import MetaBrush.Asset.Colours
( Colours )
import {-# SOURCE #-} MetaBrush.Context import {-# SOURCE #-} MetaBrush.Context
( Variables, UIElements ) ( 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 import MetaBrush.Unique
( Unique ) ( Unique )
@ -32,7 +19,14 @@ data FileBar
= FileBar = FileBar
{ fileBarBox :: !GTK.Box { fileBarBox :: !GTK.Box
, fileTabsBox :: !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 data TabLocation
@ -41,15 +35,4 @@ data TabLocation
instance Show TabLocation instance Show TabLocation
createFileBar removeFileTab :: UIElements -> Variables -> Unique -> IO ()
:: 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 ()

36
src/app/MetaBrush/UI/InfoBar.hs
View file

@ -78,6 +78,7 @@ createInfoBar :: Colours -> IO InfoBar
createInfoBar colours = do createInfoBar colours = do
infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0 infoBarArea <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ] widgetAddClasses infoBarArea [ "infoBar", "monospace", "contrast" ]
GTK.widgetSetHalign infoBarArea GTK.AlignEnd
zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0 zoomBox <- GTK.boxNew GTK.OrientationHorizontal 0
cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 cursorPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
@ -85,7 +86,7 @@ createInfoBar colours = do
botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0 botRightPosBox <- GTK.boxNew GTK.OrientationHorizontal 0
for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do for_ [ botRightPosBox, topLeftPosBox, cursorPosBox, zoomBox ] \ box -> do
GTK.boxPackEnd infoBarArea box False False 0 GTK.boxPrepend infoBarArea box
widgetAddClass box "infoBarBox" widgetAddClass box "infoBarBox"
------------- -------------
@ -94,11 +95,11 @@ createInfoBar colours = do
magnifierArea <- GTK.drawingAreaNew magnifierArea <- GTK.drawingAreaNew
zoomText <- GTK.labelNew ( Just na ) zoomText <- GTK.labelNew ( Just na )
GTK.boxPackStart zoomBox magnifierArea True True 0 GTK.boxAppend zoomBox magnifierArea
GTK.boxPackStart zoomBox zoomText True True 0 GTK.boxAppend zoomBox zoomText
void $ GTK.onWidgetDraw magnifierArea \ ctx -> GTK.drawingAreaSetDrawFunc magnifierArea $ Just \ _ cairoContext _ _ ->
( `Cairo.renderWithContext` ctx ) $ do void $ ( `Cairo.renderWithContext` cairoContext ) do
Cairo.scale 0.9 0.9 Cairo.scale 0.9 0.9
Cairo.translate 14 10 Cairo.translate 14 10
drawMagnifier colours drawMagnifier colours
@ -109,11 +110,11 @@ createInfoBar colours = do
cursorPosArea <- GTK.drawingAreaNew cursorPosArea <- GTK.drawingAreaNew
cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) cursorPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
GTK.boxPackStart cursorPosBox cursorPosArea False False 0 GTK.boxAppend cursorPosBox cursorPosArea
GTK.boxPackStart cursorPosBox cursorPosText False False 0 GTK.boxAppend cursorPosBox cursorPosText
void $ GTK.onWidgetDraw cursorPosArea \ ctx -> GTK.drawingAreaSetDrawFunc cursorPosArea $ Just \ _ cairoContext _ _ ->
( `Cairo.renderWithContext` ctx ) $ do void $ ( `Cairo.renderWithContext` cairoContext ) do
Cairo.scale 0.75 0.75 Cairo.scale 0.75 0.75
Cairo.translate 9.5 7 Cairo.translate 9.5 7
drawCursorIcon colours drawCursorIcon colours
@ -124,12 +125,11 @@ createInfoBar colours = do
topLeftPosArea <- GTK.drawingAreaNew topLeftPosArea <- GTK.drawingAreaNew
topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) topLeftPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
GTK.boxPackStart topLeftPosBox topLeftPosArea False False 0 GTK.boxAppend topLeftPosBox topLeftPosArea
GTK.boxPackStart topLeftPosBox topLeftPosText False False 0 GTK.boxAppend topLeftPosBox topLeftPosText
void $ GTK.onWidgetDraw topLeftPosArea GTK.drawingAreaSetDrawFunc topLeftPosArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawTopLeftCornerRect colours ) cairoContext
( drawTopLeftCornerRect colours )
------------------------- -------------------------
-- Bottom right position -- Bottom right position
@ -137,11 +137,11 @@ createInfoBar colours = do
botRightPosArea <- GTK.drawingAreaNew botRightPosArea <- GTK.drawingAreaNew
botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na ) botRightPosText <- GTK.labelNew ( Just $ "x: " <> na <> "\ny: " <> na )
GTK.boxPackStart botRightPosBox botRightPosArea False False 0 GTK.boxAppend botRightPosBox botRightPosArea
GTK.boxPackStart botRightPosBox botRightPosText False False 0 GTK.boxAppend botRightPosBox botRightPosText
void $ GTK.onWidgetDraw botRightPosArea \ ctx -> GTK.drawingAreaSetDrawFunc botRightPosArea $ Just \ _ cairoContext _ _ ->
( `Cairo.renderWithContext` ctx ) $ do void $ ( `Cairo.renderWithContext` cairoContext ) do
Cairo.scale -1 -1 Cairo.scale -1 -1
Cairo.translate -40 -40 Cairo.translate -40 -40
drawTopLeftCornerRect colours drawTopLeftCornerRect colours

7
src/app/MetaBrush/UI/InfoBar.hs-boot
View file

@ -1,5 +1,5 @@
module MetaBrush.UI.InfoBar module MetaBrush.UI.InfoBar
( InfoBar(..), createInfoBar, updateInfoBar ) ( InfoBar(..), updateInfoBar )
where where
-- gi-gtk -- gi-gtk
@ -22,6 +22,5 @@ data InfoBar
, cursorPosText, topLeftPosText, botRightPosText :: !GTK.Label , 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 ()

506
src/app/MetaBrush/UI/Menu.hs
View file

@ -1,52 +1,29 @@
{-# LANGUAGE BlockArguments #-} {-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-} {-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module MetaBrush.UI.Menu module MetaBrush.UI.Menu where
( newMenuBar
, Menu(..)
, FileMenu(..), EditMenu(..), ViewMenu(..), HelpMenu(..)
, ResourceType(..)
, MenuItem(..)
, createMenuBar
)
where
-- base -- base
import Control.Monad import Control.Monad
( void, unless ) ( void )
import Data.Foldable import Data.Foldable
( for_ ) ( for_, traverse_ )
import Data.Kind
( Type )
import Data.Word
( Word32 )
import GHC.Generics
( Generic )
-- generic-lens
import Data.Generics.Product.Constraints
( HasConstraints(constraints) )
-- gi-cairo-connector -- gi-cairo-connector
import qualified GI.Cairo.Render.Connector as Cairo import qualified GI.Cairo.Render.Connector as Cairo
( renderWithContext ) ( renderWithContext )
-- gi-gdk -- gi-gio
import qualified GI.Gdk as GDK import qualified GI.Gio as GIO
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as GTK import qualified GI.Gtk as GTK
@ -54,22 +31,33 @@ import qualified GI.Gtk as GTK
-- text -- text
import Data.Text import Data.Text
( Text ) ( Text )
import qualified Data.Text as Text
( unpack )
-- transformers -- transformers
import Control.Monad.IO.Class 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 -- MetaBrush
import {-# SOURCE #-} MetaBrush.Action import MetaBrush.Action
hiding ( save, saveAs )
import MetaBrush.Context import MetaBrush.Context
( UIElements(..), Variables(..) ( UIElements(..), Variables(..) )
, LR(..), Modifier(..), modifierType
)
import MetaBrush.Asset.Colours import MetaBrush.Asset.Colours
( Colours ) ( Colours )
import MetaBrush.Asset.WindowIcons import MetaBrush.Asset.WindowIcons
( drawMinimise, drawRestoreDown, drawMaximise, drawClose ) ( drawMinimise, drawRestoreDown, drawMaximise, drawClose )
import {-# SOURCE #-} MetaBrush.UI.FileBar import MetaBrush.UI.FileBar
( TabLocation(..) ) ( TabLocation(..) )
import MetaBrush.Util import MetaBrush.Util
( widgetAddClass, widgetAddClasses ) ( widgetAddClass, widgetAddClasses )
@ -77,289 +65,226 @@ import MetaBrush.Util
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Types for describing menu items. -- Types for describing menu items.
data ResourceType data MenuItem where
= Description SubmenuDescription ::
| Object { submenuLabel :: !( Maybe Text )
, submenuItems :: ![ MenuItem ]
data family MenuItem ( action :: Type ) ( submenu :: ResourceType -> Type ) ( r :: ResourceType ) } -> MenuItem
data instance MenuItem action submenu Description MenuItemDescription :: HandleAction action =>
= MenuItemDescription
{ menuItemLabel :: !Text { menuItemLabel :: !Text
, menuItemClasses :: ![ Text ] , menuItemAction :: !( Maybe ActionName, action )
, menuItemAction :: !action , menuItemAccel :: !( Maybe Text )
, menuItemAccel :: !( Maybe ( Word32, [ Modifier ] ) ) } -> MenuItem
, submenuDescription :: !( submenu Description ) Section ::
} { sectionName :: !( Maybe Text )
data instance MenuItem action submenu Object , sectionItems :: [ MenuItem ]
= MenuItem } -> MenuItem
{ menuItem :: !GTK.MenuItem
, menuItemSubmenu :: !( submenu Object )
}
data family Separator ( r :: ResourceType ) menuActionNames :: HashSet ActionName
data instance Separator Description menuActionNames = HashSet.fromList
= SeparatorDescription -- file menu
{ separatorClasses :: ![ Text ] } [ WinAction "newFile"
data instance Separator Object , WinAction "openFile"
= Separator , WinAction "openFolder"
{ separatorItem :: !GTK.MenuItem } , 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 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. -- 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 ) fileMenuDescription :: [ MenuItem ]
= Menu fileMenuDescription =
{ file :: !( MenuItem () FileMenu rt ) [ MenuItemDescription "New" ( Just $ WinAction "newFile" , ( NewFile AfterCurrentTab ) ) ( Just "<Control>n" )
, edit :: !( MenuItem () EditMenu rt ) , MenuItemDescription "Open file" ( Just $ WinAction "openFile" , ( OpenFile AfterCurrentTab ) ) ( Just "<Control>o" )
, view :: !( MenuItem () ViewMenu rt ) , MenuItemDescription "Open folder" ( Just $ WinAction "openFolder" , ( OpenFolder AfterCurrentTab ) ) ( Just "<Control><Shift>o" )
, help :: !( MenuItem () HelpMenu rt ) , MenuItemDescription "Save" ( Just $ WinAction "save" , Save ) ( Just "<Control>s" )
} , MenuItemDescription "Save as" ( Just $ WinAction "saveAs" , SaveAs ) ( Just "<Control><Shift>s" )
deriving stock Generic , MenuItemDescription "Close" ( Just $ WinAction "closeActive", CloseActive ) ( Just "<Control>w" )
, MenuItemDescription "Quit" ( Just $ WinAction "quit" , Quit ) ( Just "<Control>q" )
]
data FileMenu ( rt :: ResourceType ) editMenuDescription :: [ MenuItem ]
= FileMenu editMenuDescription =
{ new :: !( MenuItem NewFile NoSubresource rt ) [ Section Nothing
, openFile :: !( MenuItem OpenFile NoSubresource rt ) [ MenuItemDescription "Undo" ( Just $ WinAction "undo", Undo ) ( Just "<Control>z" )
, openFolder :: !( MenuItem OpenFolder NoSubresource rt ) , MenuItemDescription "Redo" ( Just $ WinAction "redo", Redo ) ( Just "<Control>y" )
, save :: !( MenuItem Save NoSubresource rt ) ]
, saveAs :: !( MenuItem SaveAs NoSubresource rt ) , Section Nothing
, close :: !( MenuItem Close NoSubresource rt ) [ MenuItemDescription "Cut" ( Just $ WinAction "cut" , Cut ) ( Just "<Control>x" )
, quit :: !( MenuItem Quit NoSubresource rt ) , MenuItemDescription "Copy" ( Just $ WinAction "copy" , Copy ) ( Just "<Control>c" )
} , MenuItemDescription "Paste" ( Just $ WinAction "paste" , Paste ) ( Just "<Control>v" )
deriving stock Generic , MenuItemDescription "Duplicate" ( Just $ WinAction "duplicate", Duplicate ) ( Just "<Control>d" )
, MenuItemDescription "Delete" ( Just $ WinAction "delete" , Delete ) ( Just "Delete" )
]
, Section Nothing
[ MenuItemDescription "Preferences" ( Nothing, () ) ( Just "<Control><Shift>p" )
]
]
data EditMenu ( rt :: ResourceType ) viewMenuDescription :: [ MenuItem ]
= EditMenu viewMenuDescription =
{ undo :: !( MenuItem Undo NoSubresource rt ) [ Section Nothing
, redo :: !( MenuItem Redo NoSubresource rt ) [ MenuItemDescription "Navigator" ( Nothing, () ) Nothing
, editSep1 :: !( Separator rt ) , MenuItemDescription "History" ( Nothing, () ) ( Just "<Control>h" )
, cut :: !( MenuItem Cut NoSubresource rt ) ]
, copy :: !( MenuItem Copy NoSubresource rt ) , Section Nothing
, paste :: !( MenuItem Paste NoSubresource rt ) [ MenuItemDescription "Strokes" ( Nothing, () ) Nothing
, duplicate :: !( MenuItem Duplicate NoSubresource rt ) , MenuItemDescription "Brushes" ( Nothing, () ) Nothing
, delete :: !( MenuItem Delete NoSubresource rt ) , MenuItemDescription "Metaparameters" ( Nothing, () ) Nothing
, editSep2 :: !( Separator rt ) ]
, preferences :: !( MenuItem () NoSubresource rt ) , Section Nothing
} [ MenuItemDescription "Transform" ( Nothing, () ) Nothing
deriving stock Generic ]
, Section Nothing
[ MenuItemDescription "Toggle guides" ( Just $ WinAction "toggleGuides", ToggleGuides ) ( Just "g" )
]
]
data ViewMenu ( rt :: ResourceType ) helpMenuDescription :: [ MenuItem ]
= ViewMenu helpMenuDescription =
{ navigator :: !( MenuItem () NoSubresource rt ) [ MenuItemDescription "About MetaBrush" ( Just $ AppAction "about", About ) ( Just "<Ctrl>question" )
, 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 }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Creating a GTK menu bar from a menu description. -- Creating a GTK popover menu bar from a menu description.
newMenuItem makeMenu :: MonadIO m => UIElements -> Variables -> GIO.Menu -> [ MenuItem ] -> m ()
:: ( MonadIO m, HandleAction action ) makeMenu uiElts@( UIElements { application, window, menuActions } ) vars menu = traverse_ \case
=> UIElements SubmenuDescription
-> Variables { submenuLabel
-> GTK.AccelGroup , submenuItems
-> MenuItem action submenu Description } -> do
-> m GTK.MenuItem submenu <- GIO.menuNew
newMenuItem uiElts vars accelGroup ( MenuItemDescription {..} ) = do makeMenu uiElts vars submenu submenuItems
menuItem <- GTK.menuItemNewWithLabel menuItemLabel GIO.menuAppendSubmenu menu submenuLabel submenu
for_ menuItemAccel \ ( key, modifiers ) -> do MenuItemDescription
GTK.widgetAddAccelerator menuItem "activate" accelGroup key ( map modifierType modifiers ) [ GTK.AccelFlagsVisible ] { menuItemLabel
GTK.containerForeach menuItem \ lbl -> widgetAddClass lbl "accelLabel" , menuItemAction = ( mbActionName, actionData )
unless ( null menuItemClasses ) do , menuItemAccel
widgetAddClasses menuItem menuItemClasses } -> do
void $ GTK.onMenuItemActivate menuItem for_ mbActionName \ actionName -> do
( handleAction uiElts vars menuItemAction ) let
pure menuItem simpleName :: Text
simpleName = actionSimpleName actionName
class CreateMenuItem desc res | desc -> res, res -> desc where case HashMap.lookup actionName menuActions of
createMenuItem :: MonadIO m => UIElements -> Variables -> GTK.AccelGroup -> ( GTK.MenuItem -> m () ) -> desc -> m res Nothing ->
instance {-# OVERLAPPING #-} error
HandleAction action ( "Could not create menu item labelled " <> Text.unpack menuItemLabel <>
=> CreateMenuItem ": missing action " <> show actionName
( MenuItem action NoSubresource Description ) )
( MenuItem action NoSubresource Object ) Just menuItemAction -> do
where _ <- GIO.onSimpleActionActivate menuItemAction
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription = do ( \ _ -> handleAction uiElts vars actionData )
menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription GIO.actionMapAddAction window menuItemAction
attachToParent menuItem for_ menuItemAccel \ accelText -> do
pure actionDetailedName <- GIO.actionPrintDetailedName simpleName Nothing
MenuItem GTK.applicationSetAccelsForAction application ( actionPrefix actionName <> actionDetailedName ) [accelText]
{ menuItem = menuItem menuItem <- GIO.menuItemNew ( Just menuItemLabel ) ( fmap ( \ name -> actionPrefix name <> actionSimpleName name ) mbActionName )
, menuItemSubmenu = NoSubresource GIO.menuAppendItem menu menuItem
} Section
instance ( HandleAction action, HasConstraints CreateMenuItem ( submenu Description ) ( submenu Object ) ) { sectionName
=> CreateMenuItem ( MenuItem action submenu Description ) ( MenuItem action submenu Object ) , sectionItems
where } -> do
createMenuItem uiElts vars accelGroup attachToParent menuItemDescription@( MenuItemDescription { submenuDescription } ) = do section <- GIO.menuNew
menuItem <- newMenuItem uiElts vars accelGroup menuItemDescription makeMenu uiElts vars section sectionItems
submenu <- GTK.menuNew GIO.menuAppendSection menu sectionName section
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 )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Creating the menu bar from its declarative specification. -- Creating the menu bar from its declarative specification.
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). -- | Add the menu bar to the given box (title bar box).
createMenuBar :: UIElements -> Variables -> Colours -> IO ( Menu Object ) createMenuBar :: MonadIO m => UIElements -> Variables -> Colours -> m GTK.PopoverMenuBar
createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do createMenuBar uiElts@( UIElements { application, window, titleBar } ) vars colours = do
accelGroup <- GTK.accelGroupNew --accelGroup <- GTK.accelGroupNew
GTK.windowAddAccelGroup window accelGroup --GTK.windowAddAccelGroup window accelGroup
( menuBar, menu ) <- newMenuBar uiElts vars accelGroup menu <- createMenu uiElts vars
widgetAddClasses menuBar [ "menuBar", "text", "plain" ] menuBar <- GTK.popoverMenuBarNewFromModel ( Just menu )
GTK.boxPackStart titleBar menuBar False False 0 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. -- 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, -- Activating a menu somehow sets the "hover" setting,
-- so instead we use the "selected" setting for actual hover highlighting. -- so instead we use the "selected" setting for actual hover highlighting.
topLevelMenuItems <- GTK.containerGetChildren menuBar -- GTK4 FIXME
for_ topLevelMenuItems \ topLevelMenuItem -> do --topLevelMenuItems <- GTK.containerGetChildren menuBar
void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do --for_ topLevelMenuItems \ topLevelMenuItem -> do
flags <- GTK.widgetGetStateFlags topLevelMenuItem -- void $ GTK.onWidgetEnterNotifyEvent topLevelMenuItem \ _ -> do
GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True -- flags <- GTK.widgetGetStateFlags topLevelMenuItem
pure False -- GTK.widgetSetStateFlags topLevelMenuItem ( GTK.StateFlagsSelected : flags ) True
void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do -- pure False
flags <- GTK.widgetGetStateFlags topLevelMenuItem -- void $ GTK.onWidgetLeaveNotifyEvent topLevelMenuItem \ _ -> do
GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True -- flags <- GTK.widgetGetStateFlags topLevelMenuItem
pure False -- GTK.widgetSetStateFlags topLevelMenuItem ( filter ( /= GTK.StateFlagsSelected ) flags ) True
-- pure False
windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0 windowIcons <- GTK.boxNew GTK.OrientationHorizontal 0
widgetAddClasses windowIcons [ "windowIcon" ] widgetAddClasses windowIcons [ "windowIcons" ]
GTK.boxPackEnd titleBar windowIcons False False 0 GTK.headerBarPackEnd titleBar windowIcons
minimiseButton <- GTK.buttonNew minimiseButton <- GTK.buttonNew
fullscreenButton <- GTK.buttonNew maximiseButton <- GTK.buttonNew
closeButton <- GTK.buttonNew closeButton <- GTK.buttonNew
GTK.boxPackStart windowIcons minimiseButton True True 0 GTK.boxAppend windowIcons minimiseButton
GTK.boxPackStart windowIcons fullscreenButton True True 0 GTK.boxAppend windowIcons maximiseButton
GTK.boxPackStart windowIcons closeButton True True 0 GTK.boxAppend windowIcons closeButton
minimiseArea <- GTK.drawingAreaNew minimiseArea <- GTK.drawingAreaNew
fullscreenArea <- GTK.drawingAreaNew maximiseArea <- GTK.drawingAreaNew
closeArea <- GTK.drawingAreaNew closeArea <- GTK.drawingAreaNew
GTK.containerAdd minimiseButton minimiseArea GTK.buttonSetChild minimiseButton ( Just minimiseArea )
GTK.containerAdd fullscreenButton fullscreenArea GTK.buttonSetChild maximiseButton ( Just maximiseArea )
GTK.containerAdd closeButton closeArea GTK.buttonSetChild closeButton ( Just closeArea )
void $ GTK.onWidgetDraw minimiseArea GTK.drawingAreaSetDrawFunc minimiseArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawMinimise colours ) cairoContext
( drawMinimise colours )
void $ GTK.onWidgetDraw fullscreenArea \ cairoContext -> do GTK.drawingAreaSetDrawFunc maximiseArea $ Just \ _ cairoContext _ _ -> do
Just gdkWindow <- GTK.widgetGetWindow window isMaximised <- GTK.getWindowMaximized window
windowState <- GDK.windowGetState gdkWindow if isMaximised
if any ( \case { GDK.WindowStateFullscreen -> True; GDK.WindowStateMaximized -> True; _ -> False } ) windowState then void $ Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext
then Cairo.renderWithContext ( drawRestoreDown colours ) cairoContext else void $ Cairo.renderWithContext ( drawMaximise colours ) cairoContext
else Cairo.renderWithContext ( drawMaximise colours ) cairoContext
void $ GTK.onWidgetDraw closeArea GTK.drawingAreaSetDrawFunc closeArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawClose colours ) cairoContext
( drawClose colours )
for_ [ minimiseButton, fullscreenButton, closeButton ] \ button -> do for_ [ minimiseButton, maximiseButton, closeButton ] \ button -> do
widgetAddClass button "windowIcon" widgetAddClass button "windowIcon"
widgetAddClass closeButton "closeWindowIcon" widgetAddClass closeButton "closeWindowIcon"
@ -367,18 +292,17 @@ createMenuBar uiElts@( UIElements { window, titleBar } ) vars colours = do
--------------------------------------------------------- ---------------------------------------------------------
-- Actions -- Actions
_ <- GTK.onButtonClicked closeButton ( quitEverything window ) _ <- GTK.onButtonClicked closeButton ( quitEverything application window )
_ <- GTK.onButtonClicked minimiseButton ( GTK.windowIconify window ) _ <- GTK.onButtonClicked minimiseButton ( GTK.windowMinimize window )
_ <- GTK.onButtonClicked fullscreenButton do _ <- GTK.onButtonClicked maximiseButton do
Just gdkWindow <- GTK.widgetGetWindow window isMaximised <- GTK.getWindowMaximized window
windowState <- GDK.windowGetState gdkWindow if isMaximised
if GDK.WindowStateFullscreen `elem` windowState
then GTK.windowUnfullscreen window
else
if GDK.WindowStateMaximized `elem` windowState
then GTK.windowUnmaximize window then GTK.windowUnmaximize window
else GTK.windowMaximize window else GTK.windowMaximize window
GTK.widgetQueueDraw maximiseArea
--------------------------------------------------------- ---------------------------------------------------------
pure menu GTK.applicationSetMenubar application ( Just menu )
pure menuBar

53
src/app/MetaBrush/UI/Menu.hs-boot
View file

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

15
src/app/MetaBrush/UI/Panels.hs
View file

@ -27,7 +27,8 @@ createPanelBar panelBox = do
widgetAddClass panelBox "panels" widgetAddClass panelBox "panels"
pane1 <- GTK.panedNew GTK.OrientationVertical pane1 <- GTK.panedNew GTK.OrientationVertical
GTK.boxPackStart panelBox pane1 True True 0 GTK.widgetSetVexpand pane1 True
GTK.boxAppend panelBox pane1
panels1 <- GTK.notebookNew panels1 <- GTK.notebookNew
panels2 <- GTK.notebookNew panels2 <- GTK.notebookNew
@ -35,8 +36,8 @@ createPanelBar panelBox = do
GTK.notebookSetGroupName panels1 ( Just "Panel" ) GTK.notebookSetGroupName panels1 ( Just "Panel" )
GTK.notebookSetGroupName panels2 ( Just "Panel" ) GTK.notebookSetGroupName panels2 ( Just "Panel" )
GTK.panedPack1 pane1 panels1 True True GTK.panedSetStartChild pane1 panels1
GTK.panedPack2 pane1 panels2 True True GTK.panedSetEndChild pane1 panels2
strokesPanel <- GTK.boxNew GTK.OrientationVertical 0 strokesPanel <- GTK.boxNew GTK.OrientationVertical 0
brushesPanel <- 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..." ) transformContent <- GTK.labelNew ( Just "Transform tab content..." )
historyContent <- GTK.labelNew ( Just "History tab content..." ) historyContent <- GTK.labelNew ( Just "History tab content..." )
GTK.boxPackStart strokesPanel strokesContent True True 0 GTK.boxAppend strokesPanel strokesContent
GTK.boxPackStart brushesPanel brushesContent True True 0 GTK.boxAppend brushesPanel brushesContent
GTK.boxPackStart transformPanel transformContent True True 0 GTK.boxAppend transformPanel transformContent
GTK.boxPackStart historyPanel historyContent True True 0 GTK.boxAppend historyPanel historyContent
pure () pure ()

126
src/app/MetaBrush/UI/ToolBar.hs
View file

@ -11,8 +11,10 @@ module MetaBrush.UI.ToolBar
where where
-- base -- base
import Control.Arrow
( second )
import Control.Monad import Control.Monad
( void ) ( void, when )
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
@ -56,8 +58,9 @@ data Mode
data ToolBar data ToolBar
= ToolBar = ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
, debugTool :: !GTK.ToggleButton } :: !GTK.ToggleButton
}
createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar createToolBar :: Variables -> Colours -> GTK.Box -> IO ToolBar
createToolBar ( Variables {..} ) colours toolBar = do createToolBar ( Variables {..} ) colours toolBar = do
@ -67,30 +70,35 @@ createToolBar ( Variables {..} ) colours toolBar = do
GTK.widgetSetValign toolBar GTK.AlignStart GTK.widgetSetValign toolBar GTK.AlignStart
GTK.widgetSetVexpand toolBar True GTK.widgetSetVexpand toolBar True
selectionTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) selectionTool <- GTK.toggleButtonNew
penTool <- GTK.radioButtonNewFromWidget ( Just selectionTool ) penTool <- GTK.toggleButtonNew
GTK.toggleButtonSetGroup penTool ( Just selectionTool )
_ <- GTK.onButtonClicked selectionTool $ STM.atomically do makeToggleGroup $
STM.writeTVar toolTVar Selection fmap
_ <- GTK.onButtonClicked penTool $ STM.atomically do ( second \ toolVal -> STM.atomically do
STM.writeTVar toolTVar Pen 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 toolSep1 <- GTK.boxNew GTK.OrientationVertical 0
pathTool <- GTK.radioButtonNew ( [] @GTK.RadioButton ) pathTool <- GTK.toggleButtonNew
brushTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) brushTool <- GTK.toggleButtonNew
metaTool <- GTK.radioButtonNewFromWidget ( Just pathTool ) metaTool <- GTK.toggleButtonNew
GTK.toggleButtonSetGroup brushTool ( Just pathTool )
_ <- GTK.onButtonClicked pathTool $ STM.atomically do GTK.toggleButtonSetGroup metaTool ( Just pathTool )
STM.writeTVar modeTVar PathMode makeToggleGroup $
fmap
( second \ modeVal -> STM.atomically do
STM.writeTVar modeTVar modeVal
STM.writeTVar partialPathTVar Nothing
STM.writeTVar recomputeStrokesTVar True STM.writeTVar recomputeStrokesTVar True
_ <- GTK.onButtonClicked brushTool $ STM.atomically do )
STM.writeTVar modeTVar BrushMode [ ( pathTool, PathMode ), ( brushTool, BrushMode ), ( metaTool, MetaMode ) ]
STM.writeTVar recomputeStrokesTVar True GTK.toggleButtonSetActive pathTool True
_ <- GTK.onButtonClicked metaTool $ STM.atomically do
STM.writeTVar modeTVar MetaMode
STM.writeTVar recomputeStrokesTVar True
toolSep2 <- GTK.boxNew GTK.OrientationVertical 0 toolSep2 <- GTK.boxNew GTK.OrientationVertical 0
@ -100,20 +108,22 @@ createToolBar ( Variables {..} ) colours toolBar = do
clicked <- GTK.toggleButtonGetActive debugTool clicked <- GTK.toggleButtonGetActive debugTool
STM.atomically do STM.atomically do
STM.writeTVar debugTVar clicked STM.writeTVar debugTVar clicked
STM.writeTVar partialPathTVar Nothing
STM.writeTVar recomputeStrokesTVar True STM.writeTVar recomputeStrokesTVar True
GTK.boxPackStart toolBar selectionTool True True 0 GTK.boxAppend toolBar selectionTool
GTK.boxPackStart toolBar penTool True True 0 GTK.boxAppend toolBar penTool
GTK.boxPackStart toolBar toolSep1 True True 0 GTK.boxAppend toolBar toolSep1
GTK.boxPackStart toolBar pathTool True True 0 GTK.boxAppend toolBar pathTool
GTK.boxPackStart toolBar brushTool True True 0 GTK.boxAppend toolBar brushTool
GTK.boxPackStart toolBar metaTool True True 0 GTK.boxAppend toolBar metaTool
GTK.boxPackStart toolBar toolSep2 True True 0 GTK.boxAppend toolBar toolSep2
GTK.boxPackStart toolBar debugTool True True 0 GTK.boxAppend toolBar debugTool
for_ [ selectionTool, penTool, pathTool, brushTool, metaTool ] \ tool -> do for_ [ selectionTool, penTool, pathTool, brushTool, metaTool, debugTool ] \ tool -> do
GTK.toggleButtonSetMode tool False -- don't display radio indicator
widgetAddClass tool "toolItem" widgetAddClass tool "toolItem"
GTK.widgetSetFocusOnClick tool False
GTK.widgetSetFocusable tool False
widgetAddClass debugTool "toolItem" widgetAddClass debugTool "toolItem"
@ -134,35 +144,37 @@ createToolBar ( Variables {..} ) colours toolBar = do
metaToolArea <- GTK.drawingAreaNew metaToolArea <- GTK.drawingAreaNew
debugToolArea <- GTK.drawingAreaNew debugToolArea <- GTK.drawingAreaNew
GTK.containerAdd selectionTool selectionToolArea GTK.buttonSetChild selectionTool ( Just selectionToolArea )
GTK.containerAdd penTool penToolArea GTK.buttonSetChild penTool ( Just penToolArea )
GTK.containerAdd pathTool pathToolArea GTK.buttonSetChild pathTool ( Just pathToolArea )
GTK.containerAdd brushTool brushToolArea GTK.buttonSetChild brushTool ( Just brushToolArea )
GTK.containerAdd metaTool metaToolArea GTK.buttonSetChild metaTool ( Just metaToolArea )
GTK.containerAdd debugTool debugToolArea GTK.buttonSetChild debugTool ( Just debugToolArea )
void $ GTK.onWidgetDraw selectionToolArea GTK.drawingAreaSetDrawFunc selectionToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawCursorIcon colours ) cairoContext
( drawCursorIcon colours )
void $ GTK.onWidgetDraw penToolArea GTK.drawingAreaSetDrawFunc penToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawPen colours ) cairoContext
( drawPen colours )
void $ GTK.onWidgetDraw pathToolArea GTK.drawingAreaSetDrawFunc pathToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawPath colours ) cairoContext
( drawPath colours )
void $ GTK.onWidgetDraw brushToolArea GTK.drawingAreaSetDrawFunc brushToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawBrush colours ) cairoContext
( drawBrush colours )
void $ GTK.onWidgetDraw metaToolArea GTK.drawingAreaSetDrawFunc metaToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawMeta colours ) cairoContext
( drawMeta colours )
void $ GTK.onWidgetDraw debugToolArea GTK.drawingAreaSetDrawFunc debugToolArea $ Just \ _ cairoContext _ _ ->
$ Cairo.renderWithContext void $ Cairo.renderWithContext ( drawBug colours ) cairoContext
( drawBug colours )
pure ( ToolBar {..} ) 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

4
src/app/MetaBrush/UI/ToolBar.hs-boot
View file

@ -24,6 +24,6 @@ instance Show Mode
data ToolBar data ToolBar
= ToolBar = ToolBar
{ selectionTool, penTool, pathTool, brushTool, metaTool :: !GTK.RadioButton { selectionTool, penTool, pathTool, brushTool, metaTool, debugTool
, debugTool :: !GTK.ToggleButton :: !GTK.ToggleButton
} }

79
src/app/MetaBrush/UI/Viewport.hs
View file

@ -4,7 +4,8 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module MetaBrush.UI.Viewport module MetaBrush.UI.Viewport
( Viewport(..), createViewport ( Viewport(..), ViewportEventControllers(..)
, createViewport
, Ruler(..) , Ruler(..)
) )
where where
@ -13,9 +14,6 @@ module MetaBrush.UI.Viewport
import Data.Foldable import Data.Foldable
( for_ ) ( for_ )
-- gi-gdk
import qualified GI.Gdk as GDK
-- gi-gtk -- gi-gtk
import qualified GI.Gtk as 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 data Viewport
= Viewport = Viewport
{ viewportDrawingArea { viewportDrawingArea
@ -32,6 +37,11 @@ data Viewport
, leftRulerDrawingArea , leftRulerDrawingArea
, topRulerDrawingArea , topRulerDrawingArea
:: !GTK.DrawingArea :: !GTK.DrawingArea
, viewportEventControllers
, rulerCornerEventControllers
, leftRulerEventControllers
, topRulerEventControllers
:: !ViewportEventControllers
} }
createViewport :: GTK.Grid -> IO Viewport createViewport :: GTK.Grid -> IO Viewport
@ -56,9 +66,9 @@ createViewport viewportGrid = do
leftRuler <- GTK.boxNew GTK.OrientationVertical 0 leftRuler <- GTK.boxNew GTK.OrientationVertical 0
topRuler <- GTK.boxNew GTK.OrientationHorizontal 0 topRuler <- GTK.boxNew GTK.OrientationHorizontal 0
GTK.containerAdd rvRulerCorner rulerCorner GTK.revealerSetChild rvRulerCorner ( Just rulerCorner )
GTK.containerAdd rvLeftRuler leftRuler GTK.revealerSetChild rvLeftRuler ( Just leftRuler )
GTK.containerAdd rvTopRuler topRuler GTK.revealerSetChild rvTopRuler ( Just topRuler )
widgetAddClasses rulerCorner [ "ruler", "rulerCorner" ] widgetAddClasses rulerCorner [ "ruler", "rulerCorner" ]
widgetAddClasses leftRuler [ "ruler", "leftRuler" ] widgetAddClasses leftRuler [ "ruler", "leftRuler" ]
@ -73,13 +83,13 @@ createViewport viewportGrid = do
GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp GTK.revealerSetTransitionType rvTopRuler GTK.RevealerTransitionTypeSlideUp
rulerCornerDrawingArea <- GTK.drawingAreaNew rulerCornerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart rulerCorner rulerCornerDrawingArea True True 0 GTK.boxAppend rulerCorner rulerCornerDrawingArea
leftRulerDrawingArea <- GTK.drawingAreaNew leftRulerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart leftRuler leftRulerDrawingArea True True 0 GTK.boxAppend leftRuler leftRulerDrawingArea
topRulerDrawingArea <- GTK.drawingAreaNew topRulerDrawingArea <- GTK.drawingAreaNew
GTK.boxPackStart topRuler topRulerDrawingArea True True 0 GTK.boxAppend topRuler topRulerDrawingArea
GTK.widgetSetHexpand rulerCorner False GTK.widgetSetHexpand rulerCorner False
GTK.widgetSetVexpand rulerCorner False GTK.widgetSetVexpand rulerCorner False
@ -91,14 +101,49 @@ createViewport viewportGrid = do
GTK.widgetSetVexpand viewportOverlay True GTK.widgetSetVexpand viewportOverlay True
viewportDrawingArea <- GTK.drawingAreaNew viewportDrawingArea <- GTK.drawingAreaNew
GTK.setContainerChild viewportOverlay viewportDrawingArea GTK.overlaySetChild viewportOverlay ( Just viewportDrawingArea )
for_ [ rulerCornerDrawingArea, leftRulerDrawingArea, topRulerDrawingArea, viewportDrawingArea ] \ drawingArea -> do -- Adding mouse event controllers to all drawing areas.
GTK.widgetAddEvents drawingArea viewportMotion <- GTK.eventControllerMotionNew
[ GDK.EventMaskPointerMotionMask viewportScroll <- GTK.eventControllerScrollNew [ GTK.EventControllerScrollFlagsBothAxes ]
, GDK.EventMaskButtonPressMask, GDK.EventMaskButtonReleaseMask viewportClicks <- GTK.gestureClickNew
, GDK.EventMaskScrollMask, GDK.EventMaskSmoothScrollMask 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 )
{- {-
----------------- -----------------

8
src/app/MetaBrush/Util.hs
View file

@ -43,10 +43,10 @@ import Control.Monad.Trans.Maybe
withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b withRGBA :: MonadIO m => GDK.RGBA -> ( Double -> Double -> Double -> Double -> m b ) -> m b
withRGBA rgba f = do withRGBA rgba f = do
r <- GDK.getRGBARed rgba r <- realToFrac <$> GDK.getRGBARed rgba
g <- GDK.getRGBAGreen rgba g <- realToFrac <$> GDK.getRGBAGreen rgba
b <- GDK.getRGBABlue rgba b <- realToFrac <$> GDK.getRGBABlue rgba
a <- GDK.getRGBAAlpha rgba a <- realToFrac <$> GDK.getRGBAAlpha rgba
f r g b a f r g b a
showRGBA :: MonadIO m => GDK.RGBA -> m String showRGBA :: MonadIO m => GDK.RGBA -> m String